I've this piece of code which is generating me an QR code, from an input field, and than saving it as .svg.
observeEvent(input$safe_qr,{
qr <- qr_code(input$qr_gen)
generate_svg(qr, "QR_Code.svg",
size = 100,
foreground = "black",
background = "white",
show = interactive())
renderPlot(qr)
})
Now I don't really need to save it, I want to see it next to my input field on the page. I have no idea how put an image inside the page.
One thing I was trying was Plot(qr) then a new window opened in edge and showed me the saved QR code. But yeah that's not what I want.
Here's a working shiny app to allow arbitrary QR generate (of text), showing in both SVG and PNG.
library(shiny)
ui <- fluidPage(sidebarLayout(
sidebarPanel(
textInput("text", label = NULL, placeholder = "(some phrase)"),
imageOutput("svgplot")
),
mainPanel(
plotOutput("plot")
)
))
server <- function(input, output, session) {
QR <- eventReactive(input$text, {
qrcode::qr_code(input$text)
})
output$svgplot <- renderImage({
txt <- isolate(input$text)
tf <- tempfile(fileext = ".svg")
qrcode::generate_svg(QR(), tf, size = 100, foreground = "black", background = "white", show = FALSE)
list(
src = normalizePath(tf),
contentType = "image/svg+xml",
width = 100, height = 100,
alt = paste("My QR code:", sQuote(txt, FALSE))
)
}, deleteFile = TRUE)
output$plot <- renderPlot({ plot(QR()) })
}
shinyApp(ui, server)
You don't need to show both, I thought I'd compare/contrast how to show them since they require different steps.
Key takeaways:
renderImage allows us to show an arbitrary image that the browser should support. The expression in this call must be a list with the attributes for the HTML img attribute, so here my list(...) is creating
<img src="path/to/tempfile.svg" contentType="image/svg+xml" width=100 height=100 alt="...">
I'm doing a two-step here: create the QR object as reactive data, and then anything that will use that will depend on QR() (my QR object). This way there will be fewer reactive-chain calls. This may not be strictly necessary if all you're doing is showing a single QR code, over to you.
shiny::renderImage requires the deleteFile= argument; if all you want to is show it, this is fine; if the user wants to right-click on the displayed SVG file and download it locally, it's still fine. In fact, since the "link" text is data:image/svg+xml;base64,PD94bWwgdmVy... and is a fairly long string (39K chars in one example), even if the temp file is deleted, this link remains unchanged and working.
Related
EDIT: solved with magick - thank you guys a lot :) Updated version in the GitHub repo, for anyone who's interested in the story of the reindeer.
I'm quite new to R and just got to know R Shiny. Yet, I am trying to do a reindeer generator. Basic principle: Combine different layers of images in order to create your personal reindeer. E.g. switch coat colours with buttons while the outlines still stay in place on top. Ideally, it should look something like this in the end (a preview I sketched with GIMP):
preview of the reindeer generator
I manage to get the images into Shiny and switch between two coats with radio buttons, for a start.
However, I don't have a clue how to display the images at the same time at the very same location so the outlines will be an extra layer on top of the coat.
You can see the issue here:
grey coat selected
brown coat selected
Here is my code. Since the file name is partly generated by the radio button input, I left the paths like that.
library(shiny)
ui <- fluidPage(
titlePanel("R-eindeer"),
sidebarLayout(
sidebarPanel(
radioButtons("check1","coat colour", choices = c("grey","brown"))
),
mainPanel(
imageOutput("reindeer_coat"),
imageOutput("reindeer_outline")
)
)
)
server <- function(input,output){
getImage <- reactive({
list(src = paste0("./coat/reindeer_", input$check1, ".png"),
width = 500,
height = 500)
})
output$reindeer_coat <- renderImage({
getImage()
}, deleteFile = FALSE)
output$reindeer_outline <- renderImage({
return(list(src = "./outlines/reindeer_outline.png",
width = 500,
height = 500,
contentType = 'image/png'))
}, deleteFile = FALSE)
}
shinyApp(ui = ui, server = server)
I would appreciate any help. Even with that issue solved, there's still a long way to go - but maybe I can learn quick enough to get stuff done until Christmas ;-)
PS: You can find all the folders, image layers and additional information in the Git repo I just created. Also, even if you can't solve my question: feel free to use the images and pass on the Christmas spirit. Reindeer content should always be free. Link to GitHub repo
As mentioned in the comments, magick can do this for you! Specifically, image_mosaic will overlay images.
Try this out:
library(shiny)
library(magick)
ui <- fluidPage(
titlePanel("R-eindeer"),
sidebarLayout(
sidebarPanel(
radioButtons("check1","coat colour", choices = c("grey","brown"))
),
mainPanel(
imageOutput("reindeer")
)
)
)
server <- function(input,output){
get_image <- function(type, color) {
image_read(file.path(type, paste0(color, ".png")))
}
output$reindeer <- renderImage({
# load the images
coat <- get_image("coat", paste0("reindeer_", input$check1))
outline <- get_image("outlines", "reindeer_outline")
# make the reindeer: overlay in order
reindeer <- c(coat, outline)
# create a temp file
tmpfile <- reindeer %>%
image_mosaic() %>%
image_flatten() %>%
image_write(tempfile(fileext='jpg'), format = 'jpg')
# render the file
return(list(src = tmpfile,
height = 300,
width = 300,
alt = "Your reindeer",
contentType = "image/jpg"))
}, deleteFile = TRUE)
}
shinyApp(ui = ui, server = server)
Say I wanted to use a custom image or shapefile in an interactive environment (like R Shiny) such as this image of a paper airplane:
I would also be willing to draw the image myself in the program to allow for full control.
But the overall goal would be to allow a user to drag the edges of the image and the program could keep track of the size of the changes for each dimension (say wingspan of the paper airplane)
Would Shiny be a possibility here, or do I need to use another program? I would also want some statistics of the changes available to the user.
Does anyone have any similar examples of such a thing, or can point me in the right direction?
Like i wrote in the comment you could use the shinyjqui package and read the session info of the user.
A reproducible example can be found below:
library(shiny)
library(shinyjqui)
library(ggplot2)
server <- function(input, output, session){
global <- reactiveValues(width = 400, height = 400)
observe({
print(session)
if(!is.null(session$clientData[["output_plot1_height"]])){
global$height <- session$clientData[["output_plot1_height"]]
global$width <- session$clientData[["output_plot1_width"]]
}
})
output$plot1 <- renderImage({
outfile <- tempfile(fileext='.png')
png(outfile, width = global$width, height = global$height)
hist(rnorm(200))
dev.off()
list(src = outfile)
}, deleteFile = TRUE)
output$clientdataText <- renderText({
paste("height is ", global$height, "width is", global$width)
})
}
ui <- fluidPage(
verbatimTextOutput("clientdataText"),
jqui_resizabled(plotOutput("plot1"))
)
shinyApp(ui, server)
I have an app that shows population models with a dropdown menu to choose the species. A plot of that species' model will be rendered and now I want an image of the species next to that plot.
The plot will change when the dates or location is changed, but the image next to it should only react to the select species input.
I've written this code for it:
ui <- fluidPage(
# ... rest of the code
wellPanel(
fluidRow(
column(3, selectInput("populatie", label = h4("Populatie"),
choices = list("PERENBLADVLO" = "PER", "OORWORM" = "OOR", "FLUWEELMIJT" = "FLU"),
selected = "PER"),
imageOutput("img1")), # here is the image
column(9, plotOutput("plot2"))
)
)
)
server <- function(input, output){
# ... rest of the code
output$img1 <- renderImage({
if(input$populatie == "PER"){
img(height = 240, width = 300, src = "PBV.jpg")
}
else if(input$populatie == "OOR"){
img(height = 240, width = 300, src = "OW.jpg")
}
else if(input$populatie == "FLU"){
img(height = 240, width = 300, src = "FM.jpg")
}
})
# ... rest of the code
}
What I get is an error saying "invalid filename argument".
I can render the images on their own though without a selection.
Thoughts?
I know this is so long ago, but here's the reason in case someone else is looking at this later:
You would use ImageOutput() and renderImage() if you could read in your images in the ui function because they don't depend on user input.. otherwise (most of the time) if you're reading in the images in your server function and the image you read depends on user input you'd use uiOutput() and renderUI()
hope this makes sense!
I still don't quite understand why it's like this, but I found a solution:
It works fine when I use uiOutput() and renderUI({}) instead of imageOutput and renderImage({}).
The rest of the code is still the same.
My Shiny app has several inputs which are used to define several parameters of a generated plot. It's very likely that the user will spend some minutes going through all possible options until he's satisfied with the output. Obviously the plot can be exported in different formats, but it's possible that the user will want to recreate the same plot with different data later, or maybe just change one small detail.
Because of this, I need to offer the user a way to export all his settings and keep that file for later use. I've developed an approach, but it isn't working well. I'm using reactiveValuesToList to get the names of all input elements and save as a simple text file with the format inputname=inputvalue. This is the downloadHandler on server.R:
output$bt_export <- downloadHandler(
filename = function() {
"export.txt"
},
content = function(file) {
inputsList <- names(reactiveValuesToList(input))
exportVars <- paste0(inputsList, "=", sapply(inputsList, function(inpt) input[[inpt]]))
write(exportVars, file)
})
This works fine, but loading isn't going very smoothly. Since I don't (and couldn't figure out how) save the input type, I have to update the values blindly. This is how I do it:
importFile <- reactive({
inFile <- input$fileImport
if (is.null(inFile))
return(NULL)
lines <- readLines(inFile$datapath)
out <- lapply(lines, function(l) unlist(strsplit(l, "=")))
return(out)
})
observe({
imp <- importFile()
for (inpt in imp) {
if (substr(inpt[2], 0, 1) == "#") {
shinyjs::updateColourInput(session, inputId = inpt[1], value = inpt[2])
} else {
try({
updateTextInput(session, inputId = inpt[1], value = inpt[2])
updateNumericInput(session, inputId = inpt[1], value = inpt[2])
updateSelectInput(session, inputId = inpt[1], selected = inpt[2])
})
}
}
})
Apart from the shinyjs::colorInput, which can be recognized by the # start, I have to use try() for the others. This works, partially, but some inputs are not being updated. Inspecting the exported file manually shows that inputs which weren't updated are there, so I suppose that updating 100+ inputs at once isn't a good idea. Also the try() part doesn't look good and is probably not a good idea.
The app is close to finished, but will probably be updated in the future, having some inputs added/changed. It's acceptable if this even make some "old" exported inputs invalid, since I'll try keep the backwards compatibility. But I'm looking for an approach that isn't just writing hundreds of lines to update the inputs one-by-one.
I've thought about using save.image() but simply using load() does not restore the app inputs. I also considered a way to somehow update all inputs at once, instead of one-by-one, but didn't come up with anything. Is there any better way to export all user inputs to a file and then load them all? It doesn't matter if it's a tweak to this one that works better or a completely different approach.
If you look at the code of the shiny input update functions, they end by session$sendInputMessage(inputId, message). message is a list of attributes that need to be changed in the input, for ex, for a checkbox input: message <- dropNulls(list(label = label, value = value))
Since most of the input have the value attribute, you can just use the session$sendInputMessage function directly on all of them without the try.
Here's an example, I created dummy_data to update all the inputs when you click on the button, the structure should be similar to what you export:
ui.R
library(shiny)
shinyUI(fluidPage(
textInput("control_label",
"This controls some of the labels:",
"LABEL TEXT"),
numericInput("inNumber", "Number input:",
min = 1, max = 20, value = 5, step = 0.5),
radioButtons("inRadio", "Radio buttons:",
c("label 1" = "option1",
"label 2" = "option2",
"label 3" = "option3")),
actionButton("update_data", "Update")
))
server.R
library(shiny)
dummy_data <- c("inRadio=option2","inNumber=10","control_label=Updated TEXT" )
shinyServer(function(input, output,session) {
observeEvent(input$update_data,{
out <- lapply(dummy_data, function(l) unlist(strsplit(l, "=")))
for (inpt in out) {
session$sendInputMessage(inpt[1], list(value=inpt[2]))
}
})
})
All the update functions also preformat the value before calling session$sendInputMessage. I haven't tried all possible inputs but at least for these 3 you can pass a string to the function to change the numericInput and it still works fine.
If this is an issue for some of your inputs, you might want to save reactiveValuesToList(input) using save, and when you want to update your inputs, use load and run the list in the for loop (you'll have to adapt it to a named list).
This is a bit old but I think is usefull to post a complete example, saving and loading user inputs.
library(shiny)
ui <- shinyUI(fluidPage(
textInput("control_label",
"This controls some of the labels:",
"LABEL TEXT"),
numericInput("inNumber", "Number input:",
min = 1, max = 20, value = 5, step = 0.5),
radioButtons("inRadio", "Radio buttons:",
c("label 1" = "option1",
"label 2" = "option2",
"label 3" = "option3")),
actionButton("load_inputs", "Load inputs"),
actionButton('save_inputs', 'Save inputs')
))
server <- shinyServer(function(input, output,session) {
observeEvent(input$load_inputs,{
if(!file.exists('inputs.RDS')) {return(NULL)}
savedInputs <- readRDS('inputs.RDS')
inputIDs <- names(savedInputs)
inputvalues <- unlist(savedInputs)
for (i in 1:length(savedInputs)) {
session$sendInputMessage(inputIDs[i], list(value=inputvalues[[i]]) )
}
})
observeEvent(input$save_inputs,{
saveRDS( reactiveValuesToList(input) , file = 'inputs.RDS')
})
})
Unless you're doing a lot of highly flexible type inputs (renderUI blocks which could be any sort of input) then you could create a list storing all current values, use dput to save them to a file with a corresponding dget to read it in.
In one app I have, I allow users to download a file storing all their uploaded data plus all their options.
output$saveData <- downloadHandler(
filename = function() {
paste0('Export_',Sys.Date(),'.sprout')
},
content = function(file) {
dataToExport = list()
#User specified options
dataToExport$sproutData$transformations=sproutData$transformations #user specified transformations
dataToExport$sproutData$processing=sproutData$processing #user specified text processing rules
dataToExport$sproutData$sc=sproutData$sc #user specified option to spell check
dataToExport$sproutData$scOptions=sproutData$scOptions #user specified spell check options (only used if spell check is turned on)
dataToExport$sproutData$scLength=sproutData$scLength #user specified min word lenght for spell check (only used if spell check is turned on)
dataToExport$sproutData$stopwords=sproutData$stopwords #user specified stopwords
dataToExport$sproutData$stopwordsLastChoice=sproutData$stopwordsLastChoice #last pre-built list selected
dput(dataToExport,file=file)
}
)
Here I make an empty list, then I stick in the values I use in my app. The reason for the dTE$sD$name structure is that I have a reactiveValues called sproutData which stores all user selected options and data. So, I preserve the structure in the output.
Then, I have a load data page which does the following:
output$loadStatusIndicator = renderUI({
worked = T
a = tryCatch(dget(input$loadSavedData$datapath),error=function(x){worked<<-F})
if(worked){
#User specified options
a$sproutData$transformations->sproutData$transformations #user specified transformations
a$sproutData$processing->sproutData$processing #user specified text processing rules
updateCheckboxGroupInput(session,"processingOptions",selected=sproutData$processing)
a$sproutData$sc->sproutData$sc #user specified option to spell check
updateCheckboxInput(session,"spellCheck",value = sproutData$sc)
a$sproutData$scOptions->sproutData$scOptions #user specified spell check options (only used if spell check is turned on)
updateCheckboxGroupInput(session,"spellCheckOptions",selected=sproutData$scOptions)
a$sproutData$scLength->sproutData$scLength #user specified min word lenght for spell check (only used if spell check is turned on)
updateNumericInput(session,"spellCheckMinLength",value=sproutData$scLength)
a$sproutData$stopwords->sproutData$stopwords #user specified stopwords
a$sproutData$stopwordsLastChoice->sproutData$stopwordsLastChoice
if(sproutData$stopwordsLastChoice[1] == ""){
updateSelectInput(session,"stopwordsChoice",selected="none")
} else if(all(sproutData$stopwordsLastChoice == stopwords('en'))){
updateSelectInput(session,"stopwordsChoice",selected="en")
} else if(all(sproutData$stopwordsLastChoice == stopwords('SMART'))){
updateSelectInput(session,"stopwordsChoice",selected="SMART")
}
HTML("<strong>Loaded data!</strong>")
} else if (!is.null(input$loadSavedData$datapath)) {
HTML(paste("<strong>Not a valid save file</strong>"))
}
})
The actual output is a table which details what it found and what it set. But, because I know all the inputs and they don't change, I can explicitly store them (default or changed value) and then explicitly update them when the save file is uploaded.
I am using R shiny to build web applications, and some of them are leveraging the great leaflet features.
I would like to create a customed and advanced popup, but I do not know how to proceed.
You can see what I can do in the project I created for this post on github, or directly in shinyapp.io here
The more complex the popup is, the weirdest my code is, as I am sort of combining R and html in a strange way (see the way I define my custompopup'i' in server.R)..
Is there a better way to proceed? What are the good practices to build such popups? If I plan to display a chart depending on the marker being clicked, should I build them all in advance, or is that possible to build them 'on the fly'? How can I do that?
Many thanks in advance for your views on this, please do not hesitate to share your answer here or to directly change my github examples!
Regards
I guess this post still has some relevance. So here is my solution on how to add almost any possible interface output to leaflet popups.
We can achieve this doing the following steps:
Insert the popup UI element as character inside the leaflet standard popup field. As character means, it is no shiny.tag, but merely a normal div. E.g. the classic uiOutput("myID") becomes <div id="myID" class="shiny-html-output"><div>.
Popups are inserted to a special div, the leaflet-popup-pane. We add an EventListener to monitor if its content changes. (Note: If the popup disappears, that means all children of this div are removed, so this is no question of visibility, but of existence.)
When a child is appended, i.e. a popup is appearing, we bind all shiny inputs/outputs inside the popup. Thus, the lifeless uiOutput is filled with content like it's supposed to be. (One would've hoped that Shiny does this automatically, but it fails to register this output, since it is filled in by Leaflets backend.)
When the popup is deleted, Shiny also fails to unbind it. Thats problematic, if you open the popup once again, and throws an exception (duplicate ID). Once it is deleted from the document, it cannot be unbound anymore. So we basically clone the deleted element to a disposal-div where it can be unbound properly and then delete it for good.
I created a sample app that (I think) shows the full capabilities of this workaround and I hope it is designed easy enough, that anyone can adapt it. Most of this app is for show, so please forgive that it has irrelevant parts.
library(leaflet)
library(shiny)
runApp(
shinyApp(
ui = shinyUI(
fluidPage(
# Copy this part here for the Script and disposal-div
uiOutput("script"),
tags$div(id = "garbage"),
# End of copy.
leafletOutput("map"),
verbatimTextOutput("Showcase")
)
),
server = function(input, output, session){
# Just for Show
text <- NULL
makeReactiveBinding("text")
output$Showcase <- renderText({text})
output$popup1 <- renderUI({
actionButton("Go1", "Go1")
})
observeEvent(input$Go1, {
text <<- paste0(text, "\n", "Button 1 is fully reactive.")
})
output$popup2 <- renderUI({
actionButton("Go2", "Go2")
})
observeEvent(input$Go2, {
text <<- paste0(text, "\n", "Button 2 is fully reactive.")
})
output$popup3 <- renderUI({
actionButton("Go3", "Go3")
})
observeEvent(input$Go3, {
text <<- paste0(text, "\n", "Button 3 is fully reactive.")
})
# End: Just for show
# Copy this part.
output$script <- renderUI({
tags$script(HTML('
var target = document.querySelector(".leaflet-popup-pane");
var observer = new MutationObserver(function(mutations) {
mutations.forEach(function(mutation) {
if(mutation.addedNodes.length > 0){
Shiny.bindAll(".leaflet-popup-content");
};
if(mutation.removedNodes.length > 0){
var popupNode = mutation.removedNodes[0].childNodes[1].childNodes[0].childNodes[0];
var garbageCan = document.getElementById("garbage");
garbageCan.appendChild(popupNode);
Shiny.unbindAll("#garbage");
garbageCan.innerHTML = "";
};
});
});
var config = {childList: true};
observer.observe(target, config);
'))
})
# End Copy
# Function is just to lighten code. But here you can see how to insert the popup.
popupMaker <- function(id){
as.character(uiOutput(id))
}
output$map <- renderLeaflet({
leaflet() %>%
addTiles() %>%
addMarkers(lat = c(10, 20, 30), lng = c(10, 20, 30), popup = lapply(paste0("popup", 1:3), popupMaker))
})
}
), launch.browser = TRUE
)
Note: One might wonder, why the Script is added from the server side. I encountered, that otherwise, adding the EventListener fails, because the Leaflet map is not initialized yet. I bet with some jQuery knowledge there is no need to do this trick.
Solving this has been a tough job, but I think it was worth the time, now that Leaflet maps got some extra utility. Have fun with this fix and please ask, if there are any questions about it!
The answer from K. Rohde is great, and the edit that #krlmlr mentioned should also be used.
I'd like to offer two small improvements over the code that K. Rohde provided (full credit still goes to K. Rohde for coming up with the hard stuff!). Here is the code, and the explanation of the changes will come after:
library(leaflet)
library(shiny)
ui <- fluidPage(
tags$div(id = "garbage"), # Copy this disposal-div
leafletOutput("map"),
div(id = "Showcase")
)
server <- function(input, output, session) {
# --- Just for Show ---
output$popup1 <- renderUI({
actionButton("Go1", "Go1")
})
observeEvent(input$Go1, {
insertUI("#Showcase", where = "beforeEnd",
div("Button 1 is fully reactive."))
})
output$popup2 <- renderUI({
actionButton("Go2", "Go2")
})
observeEvent(input$Go2, {
insertUI("#Showcase", where = "beforeEnd", div("Button 2 is fully reactive."))
})
output$popup3 <- renderUI({
actionButton("Go3", "Go3")
})
observeEvent(input$Go3, {
insertUI("#Showcase", where = "beforeEnd", div("Button 3 is fully reactive."))
})
# --- End: Just for show ---
# popupMaker is just to lighten code. But here you can see how to insert the popup.
popupMaker <- function(id) {
as.character(uiOutput(id))
}
output$map <- renderLeaflet({
input$aaa
leaflet() %>%
addTiles() %>%
addMarkers(lat = c(10, 20, 30),
lng = c(10, 20, 30),
popup = lapply(paste0("popup", 1:3), popupMaker)) %>%
# Copy this part - it initializes the popups after the map is initialized
htmlwidgets::onRender(
'function(el, x) {
var target = document.querySelector(".leaflet-popup-pane");
var observer = new MutationObserver(function(mutations) {
mutations.forEach(function(mutation) {
if(mutation.addedNodes.length > 0){
Shiny.bindAll(".leaflet-popup-content");
}
if(mutation.removedNodes.length > 0){
var popupNode = mutation.removedNodes[0];
var garbageCan = document.getElementById("garbage");
garbageCan.appendChild(popupNode);
Shiny.unbindAll("#garbage");
garbageCan.innerHTML = "";
}
});
});
var config = {childList: true};
observer.observe(target, config);
}')
})
}
shinyApp(ui, server)
The two main changes:
The original code would only work if the leaflet map is initialized when the app first starts. But if the leaflet map is initialized later, or inside a tab that isn't initially visible, or if the map gets created dynamically (for example, because it uses some reactive value), then the popups code won't work. In order to fix this, the javasript code needs to be run in htmlwidgets:onRender() that gets called on the leaflet map, as you can see in the code above.
This isn't about leaflet, but more of a general good practice: I wouldn't use makeReactiveBinding() + <<- generally. In this case it's being used correctly, but it's easy for people to abuse <<- without understanding what it does so I prefer to stay away from it. An easy almost drop-in replacement for that can be to use text <- reactiveVal(), which would be a better approach in my opinion. But even better than that in this case is instead of using a reactive variable, it's simpler to just use insertUI() like I do above.