I have been having problems combining the hide(), show() and reset() functions from the shinyjs package.
I have two divs. One div collects data using multiple user inputs and ends with a submit button. Once the submit button is pressed, another div should appear that shows the collected data in a table. In this second div, there is another button that should reset the original giv and show it again so that more data can be collected.
I tried to produce a reproducible example using some code from the shinyjs help page:
library(shiny)
library(shinyjs)
shinyApp(
ui = fluidPage(
useShinyjs(),
div(
id = "form",
textInput("name", "Name", "Dean"),
radioButtons("gender", "Gender", c("Male", "Female")),
selectInput("letter", "Favourite letter", LETTERS)
),
div(
id = "formreset",
textInput("name", "Newform", "Dean"),
radioButtons("gender", "Newform", c("Male", "Female")),
selectInput("letter", "Newform letter", LETTERS)
),
actionButton("reset_originalDiv", "Reset to original div"),
actionButton("resetName", "Reset name"),
actionButton("resetGender", "Reset Gender"),
actionButton("change_div", "Change div")
),
server = function(input, output) {
observeEvent(input$resetName, {
reset("name")
})
observeEvent(input$resetGender, {
reset("gender")
})
observeEvent(input$change_div, {
hide("form")
show("formreset")
})
observeEvent(input$reset_originalDiv, {
reset("form")
hide("formreset")
show("form")
})
}
)
As you can see, when clicking the "Reset to original div", the original div is not shown again.
Where is my mistake?
Thank you very much in advance.
Up front: perhaps show(.) is not the show you think it is, use shinyjs::show.
Finding this: add a debugging step to one of the observeEvent blocks that calls show:
observeEvent(input$change_div, {
browser()
hide("form")
show("formreset")
})
Run the app, then click on the appropriate button.
If we look at hide, it is what we think it should be:
Browse[2]> hide
function (id = NULL, anim = FALSE, animType = "slide", time = 0.5,
selector = NULL, asis = FALSE)
{
...
}
<bytecode: 0x000000000a6a7538>
<environment: namespace:shinyjs>
However, perhaps show is not:
Browse[2]> show
standardGeneric for "show" defined from package "methods"
function (object)
standardGeneric("show")
<bytecode: 0x000000001b740f30>
<environment: 0x000000001a823fb0>
Methods may be defined for arguments: object
Use showMethods(show) for currently available ones.
(This generic function excludes non-simple inheritance; see ?setIs)
This is showing us methods::show, whose first argument is indeed a character, and its return value is not really important to us in general, since shinyjs::show's return value is NULL, operating solely in side-effect. Because of what it does, we will get no warning or error indicating something might be amiss.
If you change all of your references to shinyjs::show, perhaps it will work.
Note: the first time I ran this app, it behaved as I just documented with the incorrect show. Once I tested the fix, now I cannot reproduce the problem with regular show("formreset"), so it is possible that something else may be going on. Using shinyjs::show is never wrong or different (unless you really are expecting to use a different show).
I'm not positive on the why of the behavior, but if you remove the hide("formreset") and move reset("form") to the last call made in the observeEvent(input$reset_originalDiv... you get the behavior you're looking for.
observeEvent(input$reset_originalDiv, {
shinyjs::show("form")
reset("form")
# hide("formreset")
})
You might want to use toggle in an observe({}) block based on the style condition of the form div class, which when hidden is "display:none" to manage the formreset button.
Related
I added the button but the values will automatically change before I hit "Update Order", I don't know how to fix it. Should be like this:enter image description hereBelow is my code:
library(shiny)
ui <- fluidPage(
titlePanel("My Simple App"),
sidebarLayout(
sidebarPanel(
helpText("Controls for my app"),
selectInput("fruitchoice",
label = "Choose a fruit",
choices = list("Apples",
"Oranges",
"Mangos",
"Pomegranate"),
selected = "Percent White"),
sliderInput("amt",
label = "Order Amount:",
min=0, max = 100, value=20),
actionButton ("Update","Update Order")
),
mainPanel(
helpText("Fruit Chosen:"),
verbatimTextOutput("fruit"),
helpText("Order Amount"),
verbatimTextOutput("amt")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
SelectInput <- eventReactive (input$Update , {
runif(input$fruitchoice,amt)
})
output$fruit = renderText(input$fruitchoice)
output$amt = renderText(input$amt)
}
# Run the application
shinyApp(ui = ui, server = server)
I will show you, how to rewrite your code to get this update behavior, however I would like to also get you know that this part of code:
SelectInput <- eventReactive (input$Update , {
runif(input$fruitchoice,amt)
})
Is wrong for three reasons: (1) object amt do not exists, you probably want input$amt; (2) even if you change amt to input$amt code won't work and you will get error; (3) now you are not using SelectInput in any place in your application, so there is no reason for this part to exists, however as I don't know what is your aim and how will look the final app, I'm not saying this is generally wrong.
Ok, so now about this update button. We will focus on this code:
output$fruit = renderText(input$fruitchoice)
output$amt = renderText(input$amt)
Here you instruct program to (re)render text when input$fruitchoice or (in second line) when input$amt change, but you want to (re)render text only when user clicks the button, so you need two things - first, be sure that user clicked the button and do not (re)render text when one of input$ changes. This will work:
output$fruit = renderText({
req(input$Update)
isolate(input$fruitchoice)
})
output$amt = renderText({
req(input$Update)
isolate(input$amt)
})
If I understand Shiny correctly, isolate() makes sure that text is not (re)rendering when input$ changes (however it has internally the new values) and req() makes sure that the input$Update was clicked; and when is clicked again, Shiny recomputes [(re)renders] text. It recomputes, because we didn't use isolate() on input$Update I think.
There's a few things wrong in your code. I will give a bit of explanation for each one:
You are initializing with reactive inputs. By using renderText(input$...) you create a text output that updates automatically when your input updates. Automatically is the problem here, you don't want that. We are going to write an alternative method that stores the inputs in a separate variable that we only allow to be updated when the button is pressed. We initialize that variable like so:
rv <- reactiveValues(fruit = "Apples",
amt = 20)
EventReactive creates a reactive variable that can later be used in the code. Generally speaking what you want to use in these kind of scenarios is observeEvent. You can do so like this:
observeEvent (input$Update , {
rv$fruit <- input$fruitchoice
rv$amt <- input$amt
})
We now have a list of variables under the name "rv" and an observeEvent that updates this variable every time the button gets pressed. All that is left to do is create the renderText which you can do like so:
output$fruit <- renderText(rv$fruit)
output$amt <- renderText(rv$amt)
I'm trying to update a text box based on the click events in multiple graphs. I use the observeEvent function to trigger the update of the text box. A snippet of the code is shown below.
observeEvent({
input$plot1_click
input$plot2_click
input$plot3_click
...
}, {
# only need the invalidated input
invalid_input <- which.invalid(input$plot1_click,
input$plot2_click,
input$plot3_click,
...)
updateTextInput(session,
"textbox",
label = NULL,
value = invalid_input)
})
Currently the updateTextInput function will run whenever there's a click in any of the plots, which is desired, but I can't figure out how to capture which plot is clicked last and should be used to update the text input. Is there a function to check which input is invalidated from a list of inputs?
Hi I think the easiest way is to make a separate observer for each input. This way the input that was changed last will always processed last. You can put it in a lapply if you don't want to bloat you code with repetitive code. It could look something like this
lapply(1:3, function(idx){
observeEvent({input[[paste0("plot",idx,"_click")]]},
{updateTextInput(session,
"textbox",
label = NULL,
value = input[[paste0("plot",idx,"_click")]])})
})
Hope this helps!
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.
This is my first question on stackoverflow, and I've been using R for 3 months. I have a lot to learn! Any help is much appreciated. Thank you in advance for your time.
What I WANT to happen:
The user selects a category (Animals or Foods) from a drop-down box and clicks Next once. The appropriate ui component will render and display. Then the Next button should be disabled (grayed-out) whenever the right box of the Chooser Input component is empty. Only when the user has at least one selection in the right box, should Next button be enabled and the user may click it.
The PROBLEM: After the Chooser Input component is rendered, the right box is empty, but Next is NOT disabled. Here is the error:
Warning in run(timeoutMs) :
Unhandled error in observer: argument is of length zero
observeEvent(input$widget2)
Below are a demo ui.R and sever.R to recreate my problem. (However, I will be implementing the solution into a larger, more complex GUI.) The code uses shinyBS, so you will first need to install the package and load the library. The code also uses chooserInput, which requires two files: chooser.R and www/chooser-binding.js. See the following link for more information:
http://shiny.rstudio.com/gallery/custom-input-control.html
ui
### The following libraries need to be loaded BEFORE runApp()
### library(shiny)
### library(shinyBS)
source("chooser.R") # Used for Custom Input Control UI component (chooserInput)
# chooser.R is saved in the same location as the ui.R and server.R files
# chooserInput also requires chooser-binding JScript script file, which should be located within "www" folder
shinyUI(navbarPage("navbarPage Title",
tabPanel("tabPanel Title", titlePanel("titlePanel Title"),
fluidPage(
#### NEW ROW #####################################################################################################
fluidRow(wellPanel(
# Instructions for initial screen
conditionalPanel(condition = "input.ButtonNext == 0", tags$b("Step 1: Choose category and click 'Next'")),
# Instructions for 'Foods'
conditionalPanel(condition = "input.ButtonNext == 1 && input.widget1 == 'Foods'", tags$b("Step 2: Move Food(s) of interest to the right box and click 'Next'")),
# Instructions for 'Animals'
conditionalPanel(condition = "input.ButtonNext == 1 && input.widget1 == 'Animals'", tags$b("Step 2: Move Animals(s) of interest to the right box and click 'Next'"))
)),
#### NEW ROW #####################################################################################################
fluidRow(
# Drop down box for first selection
conditionalPanel(
condition = "input.ButtonNext == 0",
selectInput("widget1", label = "",
choices = c("Foods",
"Animals"))),
# This outputs the dynamic UI components based on first selection
uiOutput("ui1")
),
#### NEW ROW #####################################################################################################
fluidRow(tags$hr()), # Horizontal line separating input UI from "Next" button
#### NEW ROW #####################################################################################################
fluidRow(
column(1, offset=10,
# UI component for 'Next' button
conditionalPanel(condition = "input.ButtonNext < 2", bsButton("ButtonNext", "Next"))
),
column(1,
HTML("<a class='btn' href='/'>Restart</a>")
)
)
) # End of fluidPage
) # End of tabPanel
)) # End of navbarPage and ShinyUI
server
shinyServer(function(input, output, session) {
# Widget to display when number of clicks of "Next" button (ButtonNext) = 1
output$ui1 <- renderUI({
if(input$ButtonNext[1]==1) {
print("I am in renderUI") # Used to help debug
# Depending on the initial selection, generate a different UI component
switch(input$widget1,
"Foods" = chooserInput("widget2", "Available frobs", "Selected frobs", leftChoices=c("Apple", "Cheese", "Carrot"), rightChoices=c(), size = 5, multiple = TRUE),
"Animals" = chooserInput("widget2", "Available frobs", "Selected frobs", leftChoices=c("Lion", "Tiger", "Bear", "Wolverine"), rightChoices=c(), size = 5, multiple = TRUE)
)
}
}) # End of renderUI
# Disable "Next" button when right side of multi select input is empty
observeEvent(input$widget2, ({
widget2_right <- input$widget2[[2]]
print(widget2_right) # Used to help debug
if(widget2_right == character(0)) {
updateButton(session, "ButtonNext", disabled = TRUE)
} else {
updateButton(session, "ButtonNext", disabled = FALSE)
}
})) # End of observeEvent
}) # End of shinyServer
A similar question (link below) mentioned using Priorities and Resume/Suspend but no example was provided. If that is a valid solution to my problem, please provide some code.
R shiny Observe running Before loading of UI and this causes Null parameters
EXTRA NOTE: The code provided is a small demo recreated from a much larger GUI that I developed for the user to make a series of selections, clicking 'Next' between each selection. Depending on the selections they make each step, new choices are generated from a csv file. Therefore, the ui component that is rendered and displayed is dependent on how many times the user has clicked 'Next' and which selections they've previously made. In the end, the selections are used to sort a large data set so the user can plot only the data they are interested in. The dual conditions are why I used conditionalPanel and the VALUE of the actionButton to render and display the current ui component that the user needs. My code works (except for the problem above - HA!). However, I have read that it is poor coding practice to use the VALUE of an actionButton. If there are any suggestions for another method to handle the dual conditions, please let me know.
In server.R, I replaced
if(widget2_right == character(0))
with
if(length(widget2_right)==0)
and now the program works as I wanted it to.
When the right-box is empty, widget2_right = character(0). I learned that comparing vectors to character(0) results in logical(0), not TRUE or FALSE. However, length(character(0)) = 0. Therefore, if(length(widget2_right)==0) will be TRUE whenever no selections are in the right-box.
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.