The app below contains a checkbox (default), a selectInput (letter), and two actionButtons (trigger1 and trigger2). In the server function, there are two observers:
observer 1 fires when the user clicks trigger1 AND the checkbox is unchecked, i.e. input$default == F.
observer 2 fires when the user clicks trigger2 AND the checkbox is checked, i.e. input$default == T.
Here is the app:
library("shiny")
ui <- fluidPage(
checkboxInput('default','Default'),
selectInput('letter', 'Letter', letters),
actionButton('trigger1', 'Trigger 1'),
actionButton('trigger2', 'Trigger 2')
)
server <- function(input, output, session) {
letter = reactive(input$letter)
#Observer 1
observeEvent(input$trigger1, {
req(!input$default)
print(letter())
})
#Observer 2
observeEvent(input$trigger2, {
req(input$default)
print(letter())
})
}
shinyApp(ui = ui, server = server)
Both observers share the same handler expression, i.e. print(letter()) and I was wondering if there was an alternative to having to write it out separately for each observer? This would be useful because the handler expression in my actual app is several lines long.
One way to do this would be to have a reactiveVal that changes in response to input$trigger1 or input$trigger2, depending on the value of input$default:
server <- function(input, output, session) {
letter = reactive(input$letter)
t = reactiveVal(0)
observeEvent(input$trigger1, {
req(!input$default)
t(t()+1)
})
observeEvent(input$trigger2, {
req(input$default)
t(t()+1)
})
observeEvent(t(), print(letter()), ignoreInit = T)
}
But I was wondering if it would be possible to store the expression in a variable and then evaluate it inside the observer using something like eval? Here is my attempt:
server <- function(input, output, session) {
letter = reactive(input$letter)
handler = quote(print(letter()))
#Observer 1
observeEvent(eventExpr = {if(isolate(input$default)) return(); input$trigger1},
handlerExpr = eval(handler))
#Observer 2 - not working
observeEvent(eventExpr = {if(!isolate(input$default)) return(); input$trigger2},
handlerExpr = eval(handler))
}
EDIT: This seems to work fine for observer 1 but not for observer 2 due to the isolate.
I'm also wary of using non-standard evaluation as I don't have much experience with it. What's wrong with my use of eval above and what is it doing exactly? Is there a better/safer alternative? Any guidance would be much appreciated.
Rather than making letter your reactive, can you make print your reactive? That way you can avoid having observeEvents for input$trigger1 and input$trigger2. Thus:
print <- reactive({
req(input$trigger1, input$trigger2, input$letter)
<your code here>
})
Related
In a large Shiny App, I have a lot of modules within other modules. These nested modules also sometimes have input controls, e.g. textInput() or actionButton, which trigger certain events also in the parent module.
The following MWE shows the problem.
The module summaryServer prints a summary of a value, but waits for the reactive from rangeServer, which is triggered by a button. I want a Testing specific for summaryServer with testServer() function from Shiny, but how can I "click" the Button in the contained rangeServer module to continue? Is that something about the Mock Shiny Session?
### TESTING ###
x <- reactiveVal(1:10)
testServer(summaryServer, args = list(var = x), {
cat("var active?", d_act(),"\n")
# -----------------------------
# How to click "go" here?
# -----------------------------
cat("var active?", d_act(), "\n")
})
### The app ###
summaryUI <- function(id) {
tagList(
textOutput(NS(id, "min")),
textOutput(NS(id, "mean")),
textOutput(NS(id, "max")),
rangeUI(NS(id, "range"))
)
}
summaryServer <- function(id, var) {
stopifnot(is.reactive(var))
moduleServer(id, function(input, output, session) {
d_act = reactiveVal("Haha nope")
range_val = rangeServer("range", var = var)
# waits to range_val
observeEvent(range_val(),{
d_act("TRUE")
message(range_val())
output$min <- renderText(range_val()[[1]])
output$max <- renderText(range_val()[[2]])
output$mean <- renderText(mean(var()))
})
})
}
rangeUI = function(id) {
textInput(inputId = NS(id, "go"), label = "Go")
}
rangeServer = function(id, var){
moduleServer(id, function(input, output, session){
# when button gets clicked
eventReactive(input$go,{
range(var(), na.rm = TRUE)
}, ignoreInit = TRUE, ignoreNULL = TRUE)
})
}
library(shiny)
ui <- fluidPage(
summaryUI("sum")
)
server <- function(input, output, session) {
x = reactiveVal(1:10)
summaryServer("sum", x)
}
# shinyApp(ui, server)
That is a tricky one. It works if you set both ignoreInit and ignoreNULL to FALSE but just because then you are not initially dependent on a change of go anymore, which is undesirable.
I do not think it is possible to change go inside of rangeServer when running testServer with summaryServer. You can however use {shinytest} to achieve this. Note that here you invoke and test the entire app. Therefore, when using modules, you have to call elements by their complete id, including namespaces.
(I changed go to an actionButton, everything else stays the same)
rangeUI <- function(id) {
actionButton(inputId = NS(id, "go"),label = "Go")
}
test_that("output updates when reactive input changes", {
# invoke app
app <- shinytest::ShinyDriver$new("app.R")
# initially, the button has`nt been clicked and the outputs are empty
testthat::expect_equal(app$getValue("summary-range-go"), 0)
testthat::expect_equal(app$getValue("summary-min"), "")
# click the button
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-range-go"), 1)
# testthat::expect_equal(app$getValue("summary-min"), "1")
# for some reason, the button value increased, hence is clicked,
# but the outputs have not been triggered yet.
# another click fixes that
app$click("summary-range-go")
testthat::expect_equal(app$getValue("summary-min"), "1")
})
I am working with a very large RShiny app and want to take advantage of code folding to organize the server.R file in this application. However, when I use the code-fold hotkey, it does not fold the various elements defined in the server (the reactive, render, etc. elements).
I'd like to be able to take this
# observe some things
observe({
query <- parseQueryString(session$clientData$url_search)
if (!is.null(query[['tab']])) {
updateTabItems(session, "sidebarMenu", selected = query[['tab']])
}
if (!is.null(query[['player']])) {
updateSelectInput(session, "profile", selected = query[['player']])
}
})
# Lots of "reactive" data fetching functions
league_stats <- reactive({
get1 <- fetch('yada')
return(get1)
})
# another reactive
shooting <- reactive({
get1$SHORT_MR_MADE<-sum(get1$short_mr_fgm,na.rm=T)
...
...
)}
and collapse it into this (or something like this) by just hitting the code-collapse hotkey.
# observe some things
observe({--})
# Lots of "reactive" data fetching functions
league_stats <- reactive({--})
# another reactive
shooting <- reactive({--})
Is this possible to do with R / RStudio? I would like to avoid using the 4 # signs #### above the function to code fold, as this will hide the shooting <- reactive({--}) strings as well, however I'd like to still have show (and just hide the code inside).
I will oftentimes wrap code in functions since functions collapse, however I cannot wrap RShiny reactive elements in functions (or, i'm not sure how), as it seems like this breaks the app.
Shiny reactives behave as other functions, but you need to take care about passing to them the input, session or other reactives (as function, not as value) they need.
As an illustration :
library(shiny)
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
Collapsed code :
Another way to do this without creating them as functions is to put an identifier above each code chunk:
library(shiny)
# Generate UI ----
generateUI <- function() {fluidPage(
actionButton("do", "Click Me"),
textOutput('counter')
)}
ui <- generateUI()
# Observer ----
myobserver <- function(input,counter) {
observeEvent(input$do, {
cat('Clicked \n')
counter(counter()+1)
})
}
# Formatter ----
myformater <- function(counter) {
renderText(paste('count is',counter()))
}
# Server ----
server <- function(input, output, session) {
counter <- reactiveVal(0)
myobserver(input,counter)
output$counter <- myformater(counter)
}
shinyApp(ui, server)
You will then be able to collapse code segments in between the two identifiers to view as shown below:
Goal and Current Approach
I have a module, which can delete its own UI. I also want to be able to call this killing functionality from outside the module, hence I pass an additional reactive to the module's server logic and call the killing routine when this reactive fires.
So far so good. Now I want to implement a function which first kills all instances of my module and then adds new instances of this module and this is where I struggle with the design I have chosen.
Issue
What I would need is that before my input$add5 observer adds any new instances, all old instances are killed. This would be done by setting kill_switch(TRUE), but the problem is that before the observer in my module can react to that, the input$add5 observer continues to add new modules, which reset the kill_switch to FALSE and basically the old instances are never killed.
Basically, in the current design I would like that the observer on kill_switch reacts immediately after I change the flag and only after this is done, my add5 observer continues.
What I need
I think that my design is not optimal, thus any recommendations of how to set up the interface between the main application and the module would be highly appreciated.
Code
library(shiny)
boxer_ui <- function(id) {
ns <- NS(id)
div(
id,
id = ns("killme"),
style = "background-color:steelblue; font-size: xx-large; color: white")
}
boxer <- function(input, output, session, kill_switch) {
ns <- session$ns
observe({
req(kill_switch())
removeUI(paste0("#", ns("killme")))
})
}
ui <- fluidPage(actionButton("new", "new"),
actionButton("killall", "Kill All"),
actionButton("add5", "Kill All & Add 5"),
fluidRow(id = "content"))
server <- function(input, output, session) {
ids <- reactiveVal(0)
kill_switch <- reactiveVal(FALSE)
handler <- reactiveValues()
add_new <- function() {
kill_switch(FALSE)
ids(ids() + 1)
new_id <- paste0("id", ids())
insertUI("#content", "beforeEnd", boxer_ui(new_id))
handler[[new_id]] <- callModule(boxer, new_id, kill_switch)
}
observeEvent(input$new, {
isolate({
add_new()
})})
observeEvent(input$add5, {
isolate({
kill_switch(TRUE)
replicate(5, add_new())
})})
observeEvent(input$killall, kill_switch(TRUE))
}
shinyApp(ui, server)
One solution I could think of is to split remove / add as follows:
server <- function(input, output, session) {
ids <- reactiveVal(0)
kill_switch <- reactiveVal(FALSE)
add5 <- reactiveVal(FALSE)
handler <- reactiveValues()
add_new <- function() {
kill_switch(FALSE)
ids(ids() + 1)
new_id <- paste0("id", ids())
insertUI("#content", "beforeEnd", boxer_ui(new_id))
handler[[new_id]] <- callModule(boxer, new_id, kill_switch)
}
observeEvent(input$new, {
isolate({
add_new()
})})
observeEvent(input$add5, {
isolate({
kill_switch(TRUE)
add5(TRUE)
})})
observe({
req(add5())
isolate({
replicate(5, add_new())
add5(FALSE)
})
})
observeEvent(input$killall, kill_switch(TRUE))
}
This is however based on the assumption that the observer will never be interrupted by any other observer. Is that true? In this case I could also add priority parameters to ensure that the inner observer is fired first.
Can anybody conform that my assumption is right?
I am trying to create a table using Shiny, where the user can click on a row in order to see further information about that row. I thought I understood how to do this (see code attached).
However, right now as soon as the user clicks the "getQueue" action button, the observeEvent(input$fileList_cell_clicked, {}) seems to get called. Why would this be called before the user even has the chance to click on a row? Is it also called when the table is generated? Is there any way around this?
I need to replace "output$devel <- renderText("cell_clicked_called")" with code that will have all sorts of errors if there isn't an actual cell to refer to.
Thank you for any advice!
ui <- fluidPage(
actionButton("getQueue", "Get list of queued files"),
verbatimTextOutput("devel"),
DT::dataTableOutput("fileList")
)
shinyServer <- function(input, output) {
observeEvent(input$getQueue, {
#get list of excel files
toTable <<- data.frame("queueFiles" = list.files("queue/", pattern = "*.xlsx")) #need to catch if there are no files in queue
output$fileList <- DT::renderDataTable({
toTable
}, selection = 'single') #, selection = list(mode = 'single', selected = as.character(1))
})
observeEvent(input$fileList_cell_clicked, {
output$devel <- renderText("cell_clicked_called")
})}
shinyApp(ui = ui, server = shinyServer)
minimal error code
DT initializes input$tableId_cell_clicked as an empty list, which causes observeEvent to trigger since observeEvent only ignores NULL values by default. You can stop the reactive expression when this list is empty by inserting something like req(length(input$tableId_cell_clicked) > 0).
Here's a slightly modified version of your example that demonstrates this.
library(shiny)
ui <- fluidPage(
actionButton("getQueue", "Get list of queued files"),
verbatimTextOutput("devel"),
DT::dataTableOutput("fileList")
)
shinyServer <- function(input, output) {
tbl <- eventReactive(input$getQueue, {
mtcars
})
output$fileList <- DT::renderDataTable({
tbl()
}, selection = 'single')
output$devel <- renderPrint({
req(length(input$fileList_cell_clicked) > 0)
input$fileList_cell_clicked
})
}
shinyApp(ui = ui, server = shinyServer)
I have a textInput widget, and now whenever I start typing in the widget, shinyApp tries to evaluate the unfinished content in the textInput widget and results in many errors. I'm aware that adding an action Button "Calculate" would easily solve the problem. However, my app does not have space left for one more button. So, I'd like to know if there's a way that the textInput widget would "listen" to a keyboard event, such as when the user hits "Enter?" Thanks in advance!
Very good question. Here is an example of the way I use; this app shows a ggplot and the user gives the title of the ggplot in a textbox - but the title changes reacts only when "Return" is pressed:
js <- '
$(document).on("keyup", function(e) {
if(e.keyCode == 13){
Shiny.onInputChange("keyPressed", Math.random());
}
});
'
shinyApp(
ui = bootstrapPage(
tags$script(js),
textInput("title", label = "Title"),
plotOutput("ggplot")
),
server = function(input, output, session){
Title <- reactiveVal()
observeEvent(input[["keyPressed"]], {
Title(input[["title"]])
})
output[["ggplot"]] <- renderPlot({
ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width)) +
geom_point() +
ggtitle(Title())
})
}
)
Explanations:
This Javascript code:
$(document).on("keyup", function(e) {
if(e.keyCode == 13){
Shiny.onInputChange("keyPressed", Math.random());
}
});
creates a new Shiny input, namely input$keyPressed which receives a random number when the "Return" key is pressed anywhere.
Then I define a reactive value which takes the value input$title given in the textbox by the user, only when input$keyPressed changes:
Title <- reactiveVal()
observeEvent(input[["keyPressed"]], {
Title(input[["title"]])
})
And finally I pass this reactive value to ggtitle:
output[["ggplot"]] <- renderPlot({
ggplot(iris, aes(x=Sepal.Length, y=Sepal.Width)) +
geom_point() +
ggtitle(Title())
})
Here is an app that I built, and solves a similar problem.
The idea is to have listen to both the keypress and the button, and make sure they work together well. In your case, you should be able to make something even simpler because you don't need the button.
I hope you like it.
library(shiny)
# This is a demo app to test a key binding on an actionButton
# Uncommenting the info item (on both UI and server) will display internal stuff
runApp(
list(
#############################################
# UI
#############################################
ui = bootstrapPage(
textInput ("myinput", label = "Write something here"),
tags$script('
$(document).on("keydown", function (e) {
Shiny.onInputChange("lastkeypresscode", e.keyCode);
});
'),
actionButton("GO", "Lancer le matching !"),
# verbatimTextOutput("info"),
verbatimTextOutput("results")
),
#############################################
# SERVER
#############################################
server = function(input, output, session) {
# There are state variables for the input text and GO button
curr.val <- "" # Corresponds to the current displayed input$myinput
curr.go <- 0 # Corresponds to the last known GO value (integer)
lastEvent <- reactive({
# Is reactive to the following events
input$GO
input$lastkeypresscode
# Decide which action should be taken
if(input$GO > curr.go) {
# The user pushed the GO actionButton, so take action
action <- 1
curr.go <<- input$GO
} else if(input$lastkeypresscode == 13) {
# The user pressed the Enter key, so take action
action <- 1
} else {
# The user did anything else, so do nothing
action <- 0
}
return(action)
})
output$results = renderPrint({
if(lastEvent() == 1) {
curr.val <<- isolate(input$myinput)
}
curr.val
})
# output$info = renderText({
# paste(curr.val, curr.go, input$lastkeypresscode, sep = ", ")
# })
}
)
)
I created a simple app as an example, where the user can write the name of a city and after pressing ENTER it returns latitude and longitude:
library(shiny)
library(ggmap)
runApp(
list(
#############################################
# UI
#############################################
ui = fluidPage( title = "City Search" ,
position= "static-top",
tags$script(' $(document).on("keydown", function (e) {
Shiny.onInputChange("lastkeypresscode", e.keyCode);
});
'),
# Search panel:
textInput("search_city", "" , placeholder= "City"),
verbatimTextOutput("results")),
#############################################
# SERVER
#############################################
server = function(input, output, session) {
observe({
if(!is.null(input$lastkeypresscode)) {
if(input$lastkeypresscode == 13){
target_pos = geocode(input$search_city, messaging =FALSE)
LAT = target_pos$lat
LONG = target_pos$lon
if (is.null(input$search_city) || input$search_city == "")
return()
output$results = renderPrint({
sprintf("Longitude: %s ---- Latitude: %s", LONG, LAT)
})
}
}
})
}
)
)
Note that for catching the ENTER input the code is 13, i.e. input$lastkeypresscode == 13.
In your case, the problem is reactive programming and this is the reason that you need something to manage this situation. My recommendation is to use observer pattern or validate function.
Observer pattern: shiny implements the observer pattern which is
useful to act when an event happens in an object (it can be a click
in a button, new value in an input...).
Validate function: the functionality of this process is similar to an
if/else statement. Indeed, there is need what is the if to check the
parameter, if the values are wrong, there will be an error message.
To know how to use observe pattern and the validate function, click on the previous link (in the Shiny website is everything explained).