I would like to put an action button, to zoom and enlarge image on my shiny app. See the code below, the shiny app render two images "space_1.jpg" and "space_2.jpg" (already created), according to the choice of the user. The idea would be to allow the user the user to enlarge image in a popup window. I don't know how to make it possible. Many thanks for your help,
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
sidebarPanel(width=6,
radioButtons("choice", label = h4("Choose"),choices = c("space_1","space_2"), selected = "space_1"),
dropdown(downloadButton(outputId = "down_image_test",label = "Download plot"),size = "xs",icon = icon("download", class = "opt"), up = TRUE),
actionBttn(inputId = "zoom_image_test",icon = icon("search-plus", class = "opt"),style = "fill",color = "danger",size = "xs")
),
mainPanel(h2("main panel"),imageOutput('image_test'))
)
server <- function(input, output){
output$image_test <- renderImage({
nam=paste0(getwd(),"/",input$choice,".jpg")
list(src = nam,height = 200)}, deleteFile = FALSE)
output$down_image_test <- downloadHandler(
filename = "test.jpg",
content = function(file) {
nam=paste0(getwd(),"/",input$choice,".jpg")
file.copy(nam, file)
})
}
shinyApp(ui,server)
Related
ive something pretty weird and I don't know how to get my head around.
I just want to make an leaflet app accessible via shiny apps. It uses mapbox as a basemap.
No matter how I turn it, I get an error and the app crashes. This happens most of the time as soon as two users want to use the app. The logs confuse me.
I need some assistance on how to deploy and store tokens on shinyapp, especially the mapbox one and making it accessible for two instances. I have google API Tokens inside and they work without any problems.
On my computer the script works nicely.
If I Do
mb_access_token("MAPBOX_TOKEN", install = TRUE)
readRenviron("~/.Renviron")
I get an app shutdown with the logs
Warning: Error in : A MAPBOX_PUBLIC_TOKEN already exists. You can overwrite it with the argument overwrite=TRUE
when I change my code to overwrite = TRUE instead, I get the Error
Error: Mapbox Token already exists
The whole code is shown here:
library(leaflet)
library(mapboxapi)
library(mapview)
library(shiny)
library(shinydashboard)
library(remotes)
library(dplyr)
library(googleway)
library(tidyverse)
library(pagedown)
dashboard <- dashboardPage(
skin = "black",
dashboardHeader(title = "Analytics Tool"),
dashboardSidebar(
sidebarMenu(
menuItem("Kartengrundlage", tabName = "kgl"),
menuItem("Erreichbarkeit", tabName = "iso")
)
),
dashboardBody(
tags$style(type = "text/css", "#map {height: calc(100vh - 80px) !important;}"),
tabItems(
# First tab content
tabItem(tabName = "kgl",
fluidRow(box(width = 12, textInput("ort", "Ort", "TurmstraBe 20, 10551"))),
fluidRow(box(width = 12, height = 780, solidHeader = TRUE, leaflet::leafletOutput(outputId = "mymap", height = 720), title = "Map"),
fluidRow(box(width = 12, solidHeader = TRUE, title = downloadButton("exportmaphtml","Export as HTML"),downloadButton("exportmappdf","Export as pdf"), downloadButton("exportmappng","Export as jpeg"))
))),
# Second tab content
tabItem(tabName = "iso",
fluidRow(
))
))
)
db_server <- function(input, output,session) {
output$exportmappdf <- downloadHandler(
filename = "map.pdf",
content = function(file) {
mapshot(map$dat, url = "/map.html", remove_controls = c("zoomControl", "layersControl", "homeButton", "scaleBar",
"drawToolbar", "easyButton", "control"))
chrome_print("map.html", output = "map.pdf" )
file.copy("map.pdf", file)
}
)
output$exportmaphtml <- downloadHandler(
filename = "map.html",
content = function(file) {
mapshot(map$dat, url = paste0(getwd(), "/map.html"), remove_controls = c("zoomControl", "layersControl", "homeButton", "scaleBar",
"drawToolbar", "easyButton", "control"))
file.copy(paste0(getwd(), "/map.html"), file)
}
)
output$exportmappng <- downloadHandler(
filename = "map.png",
content = function(file) {
mapshot(map$dat, url = "map.html", remove_controls = c("zoomControl", "layersControl", "homeButton", "scaleBar",
"drawToolbar", "easyButton", "control"))
chrome_print("map.html", output = "map.png", format = "png")
file.copy(paste0(getwd(), "/map.png"), file)
}
)
Ort_geocode <- reactive({
Places <-
google_geocode(
address = input$ort, #'TurmstraBe 20, 10551',#
simplify = TRUE,
set_key("GOOGLE_KEY"))
keeps2 <- c("geometry", "formatted_address", "place_id")
Location_Clean = Places$results[keeps2]
Location_Clean_2 <- Location_Clean %>%
unnest(geometry) %>%
unnest(location) %>%
subset(select = c("lat", "lng"))
return(Location_Clean_2)
})
set_key( "GOOGLE_KEY" )
mb_access_token("MAPBOX_TOKEN", install = TRUE)
readRenviron("~/.Renviron")
map <- reactiveValues(dat = 0)
output$mymap <- renderLeaflet({
map$dat <-leaflet(Ort_geocode()) %>%
setView(Ort_geocode()$lng, Ort_geocode()$lat, zoom = 12) %>%
addMapboxTiles(style_id = "xyz",
username = "xyz") %>%
addMarkers(lat= Ort_geocode()$lat, lng= Ort_geocode()$lng, group = "Standort") %>%
addLayersControl(
overlayGroups = c("Standort"),
options = layersControlOptions(collapsed = TRUE))
})
}
shinyApp (ui = dashboard , server = db_server)
Best regards,
Sebastian
In my Shiny app, I produce a plot that is quite heavy. When I want to download this plot, R first produces the PNG file in the background and then opens the file system to choose where I want to save it.
The problem is that the plot creation takes some time after clicking on the download button, and therefore the user doesn't know if it worked.
Example below: the plot is a bit heavy so it takes some time to appear. Wait for it to appear before clicking on the "download" button.
library(shiny)
library(ggplot2)
foo <- data.frame(
x = sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE),
y = sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE)
)
ui <- fluidPage(
downloadButton('foo'),
plotOutput("test")
)
server <- function(input, output) {
output$test <- renderPlot(ggplot(foo, aes(x, y)) + geom_point())
output$foo = downloadHandler(
filename = 'test.png',
content = function(file) {
ggsave(file)
}
)
}
shinyApp(ui, server)
Is there a way to invert the process, i.e first let the user choose where to save the plot and then produce the PNG in the background? I think that would provide a better user experience.
Regarding your comment below #manro's answer: promises won't help here.
They are preventing other shiny sessions from being blocked by a busy session. They increase inter-session responsiveness not intra-session responsiveness - although there are (potentially dangerous) workarounds.
See this answer for testing:
R Shiny: async downloadHandler
In the end the downloadButton just provides a link (a-tag) with a download attribute.
If the linked resource does not exist when the client tries to access it the browser will throw an error (as it does when clicking the downloadButton before the plot is ready in your MRE).
Also the dialog to provide the file path is executed by the clients browser after clicking the link (and not by R).
I think somehow notifying the user is all you can do:
library(shiny)
library(ggplot2)
foo <- data.frame(
x = sample(seq(1, 20, by = 0.01), 1e5, replace = TRUE),
y = sample(seq(1, 20, by = 0.01), 1e5, replace = TRUE)
)
ui <- fluidPage(
tags$br(),
conditionalPanel(condition = 'output.test == null', tags$b("Generating plot...")),
conditionalPanel(condition = 'output.test != null', downloadButton('foo'), style = "display: none;"),
plotOutput("test")
)
server <- function(input, output, session) {
output$test <- renderPlot(ggplot(foo, aes(x, y)) + geom_point())
output$foo = downloadHandler(
filename = 'test.png',
content = function(file) {
showNotification(
ui = tags$b("Preparing download..."),
duration = NULL,
closeButton = TRUE,
id = "download_notification",
type = "message",
session = session
)
ggsave(file)
removeNotification(id = "download_notification", session = session)
}
)
}
shinyApp(ui, server)
This is my first Shiny App, so I'm sure it could be improved ;)
I think, that from the point of UX - it is better to do in the following way: "display a graph -> save the graph"
An addition:
So, I added a busy spinner, now an user of this app can know that this graph still rendering. You can use several styles, choose your favourite there:
library(shiny)
library(ggplot2)
library(shinybusy)
#your data
df <- data.frame(
x <- sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE),
y <- sample(seq(1, 20, by = 0.01), 5*1e5, replace = TRUE)
)
#your plot
plot_df <- ggplot(df, aes(x, y)) + geom_point()
#my plot
my_plot <- ggplot(diamonds, aes(price, fill = cut)) +
geom_histogram(binwidth = 500)
ui <- fluidPage(
#our buttons
br(),
actionButton("button1", label = "View graph"),
br(),
br(),
plotOutput("button1"),
uiOutput("button2"),
add_busy_spinner(spin = "fading-circle")
)
server <- function(input, output) {
observeEvent(input$button1, {
output$button1 <- renderPlot(my_plot)
output$button2 <- renderUI({
br()
downloadButton("button3")
})
})
output$button3 <- downloadHandler(
filename <- 'test.png',
content <- function(file){
ggsave(file)
}
)
}
shinyApp(ui, server)
I recently started using rPivotTable to produce some impressive charts and tables. I am using rPivotTable in a Shiny application. I was wondering if it is possible to export the output of the rPivotTable(Table, Bar chart, line chart etc) as image from the web browser. In RStudio(without Shiny), it can be done as the viewer has an option for Export->Save as Image. Is there any way to save the charts and tables.
A pivotTable is a htmlwidget, so you can use htmlwidgets::saveWidget to save the table in a html file and webshot::webshot to export it to png (or pdf).
library(shiny)
library(rpivotTable)
library(htmlwidgets)
library(webshot)
ui <- fluidPage(
br(),
rpivotTableOutput("pivotbl"),
br(),
downloadButton("export", "Export")
)
server <- function(input, output, session){
pivotTable <- rpivotTable(
Titanic,
rows = "Survived",
cols = c("Class","Sex"),
aggregatorName = "Sum as Fraction of Columns",
inclusions = list( Survived = list("Yes")),
exclusions= list( Class = list( "Crew")),
vals = "Freq",
rendererName = "Table Barchart"
)
output[["pivotbl"]] <- renderRpivotTable({
pivotTable
})
output[["export"]] <- downloadHandler(
filename = function(){
"pivotTable.png"
},
content = function(file){
tmphtml <- tempfile(fileext = ".html")
saveWidget(pivotTable, file = tmphtml)
webshot(tmphtml, file = file)
}
)
}
shinyApp(ui, server)
EDIT
Here is a way to export only the graph, using the dom-to-image JavaScript library.
Download the file dom-to-image.min.js and put it in the www subfolder of the app.
Here is the app:
library(shiny)
library(rpivotTable)
js <- "
function filter(node){
return (node.tagName !== 'i');
}
function exportPlot(filename){
var plot = document.getElementsByClassName('pvtRendererArea');
domtoimage.toPng(plot[0], {filter: filter, bgcolor: 'white'})
.then(function (dataUrl) {
var link = document.createElement('a');
link.download = filename;
link.href = dataUrl;
link.click();
});
}
Shiny.addCustomMessageHandler('export', exportPlot);
"
ui <- fluidPage(
tags$head(
tags$script(src = "dom-to-image.min.js"),
tags$script(HTML(js))
),
br(),
rpivotTableOutput("pivotbl"),
br(),
actionButton("export", "Export")
)
server <- function(input, output, session){
pivotTable <- rpivotTable(
Titanic,
rows = "Survived",
cols = c("Class","Sex"),
aggregatorName = "Sum as Fraction of Columns",
inclusions = list( Survived = list("Yes")),
exclusions= list( Class = list( "Crew")),
vals = "Freq",
rendererName = "Table Barchart"
)
output[["pivotbl"]] <- renderRpivotTable({
pivotTable
})
observeEvent(input[["export"]], {
session$sendCustomMessage("export", "plot.png")
})
}
shinyApp(ui, server)
I'm trying to shift elements out of the way for rendered images not to overlap with anything (trying to do it dynamically so that any size page fits and just pushed everything out of the way sort of)... Pretty new to this whole thing. Thank you in advance!
library(shiny)
library(webshot)
ui <- fluidPage(
titlePanel(
fluidRow ( align = "center", h3("Screens"))
),
sidebarLayout(
#Side panel lay out to include variant, gene and disease info relevant to interpretation
sidebarPanel(width=3,
h5("Screens")),
mainPanel(
textInput("screen1", h5("Screenshot1"),
value = "http://example.com/", width = "100%", placeholder = NULL),
imageOutput("screen1"),
textInput("screen2", h5("Screenshot2"),
value = "http://example.com/", width = "100%", placeholder = NULL),
imageOutput("screen2")
)))
server <- function(input, output, session) {
output$screen1 <- renderImage({
webshot(input$screen1, zoom = 1,
file = "screen1.png")
list(src = "screen1.png",
contentType = 'image/png')
})
output$screen2 <- renderImage({
webshot(input$screen2 , zoom = 1,
file = "screen2.png")
list(src = "screen2.png",
contentType = 'image/png')
})
}
shinyApp(ui = ui, server = server)
I have a UI that is projectdashboard in R shiny. I want to be able to type in a text/search box and have the data associated with it show up as i type.
server <- function(input, output,session) {
output$ui_names = renderUI({
name_list = mydata()[,"names"]
pickerInput("name", label=h3(" Names:"),
choices = sort(unique(name_list)),options = list("actions-box" = TRUE,"live-search" = TRUE,"none-selected-text"='Select Names'),
selected = NULL,multiple = TRUE)
})
ui <- dashboardPage(
dashboardHeader(title=textOutput("title"),titleWidth = 1500),
dashboardSidebar(
uiOutput("ui_names")
)
shinyApp(ui = ui, server = server)
This however does not give me expected or working results. How can i put a text/searchbar in the dashboard side bar, that will 'live-search' the data i am feeding it.
you can use the following:
sidebarSearchForm(textId = "searchText", buttonId = "searchButton",label = "Search...")
Please check if this meet your requirements