I have to swtiches. I want each switch to force the other one to FALSE should they become TRUE. (e.g. if you 'toggle' switch1 (= TRUE), and switch2 = TRUE, then switch2 should be changed to FALSE).
This is a simplified version of what I'm trying to achieve:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <- fluidPage(
materialSwitch(inputId = "switch1", label = "Switch 1", status = "danger"),
materialSwitch(inputId = "switch2", label = "Switch 2", status = "danger")
)
server <- function(input, output, session) {
observeEvent(input$switch1, {
#if (is.null(input$switch1)) return(NULL)
if (input$switch1 == TRUE && input$switch2 == TRUE) {
updateMaterialSwitch(session = session, "switch2", status = "danger", value = FALSE)
}
},
ignoreInit = TRUE)
}
shinyApp(ui, server)
I tried passing the input to a reactive event, but everytime I trigger switch1 after switch2 has been triggered, the app enters an endless loop. Any suggestions?
The end game would be for condition to work both ways, but for now since it doens't even work in one direction I would appreciate some help there.
Please check the following:
library(shiny)
library(shinyWidgets)
ui <- fluidPage(
materialSwitch(inputId = "switch1", label = "Switch 1", status = "danger"),
materialSwitch(inputId = "switch2", label = "Switch 2", status = "danger")
)
server <- function(input, output, session) {
observeEvent(input$switch1, {
if (input$switch1 == TRUE && input$switch2 == TRUE) {
updateMaterialSwitch(session = session, "switch2", value = FALSE)
}
})
observeEvent(input$switch2, {
if (input$switch1 == TRUE && input$switch2 == TRUE) {
updateMaterialSwitch(session = session, "switch1", value = FALSE)
}
})
}
shinyApp(ui, server)
Related
I have a shiny app in which a datatable is displayed and upon a click on a row, a modalDialog opens in which I embedded a glide from shinyglide. This worked fine until I introduced a next_condition to the second screen. Now whenever the first box is selected (or after deselecting everything and selecting again), the glide jumps back to the first screen. If you now change the option on the first screen, then the behaviour gets very strange altogether. I have no idea what causes this or where to start to fix it. Below is a (not so small) mockup example of my app which includes the observed behaviour (if you uncomment the next_condition, everything works fine). The important part to the problem is the server part in the end, the rest is just setup to make the app fully functional.
UPDATE:
I have tried to shorten the example by getting rid of the datatable and the modalDialog, but I could not replicate the behaviour this way. So it seems to me the interaction between modalDialog and glide is at fault. I was however able to shorten it a tiny bit by getting rid of the reactive variables without changing the result.
UPDATE 2:
Also posted it here, but the answer has not (yet) worked for me.
Code:
Library Calls:
library(shiny)
library(shinydashboard)
library(shinyBS)
library(shinyglide)
library(shinyWidgets)
library(shinyjs)
library(DT)
UI:
ui <- dashboardPage(skin = 'purple',
dashboardHeader(title = "Shinyglide Example"),
dashboardSidebar(disable = TRUE),
dashboardBody(
useShinyjs(),
tags$head(tags$style("#modal1 .modal-body {min-height:750px; padding: 10px}
#modal1 .modal-dialog { width: 1280px; height: 1280px;}"
)),
fixedRow(
column(width = 12,
box(title = "I am the table!",width = NULL,status = 'info',solidHeader = TRUE,
DT::dataTableOutput("table")))
)
)
)
Setup Functions:
render_my_table <- function(){
col_a <- c("A","B","C","D","E")
col_b <- c("Human","Cat","Human","Dog","Dog")
col_c <- c(35,7,42,5,11)
col_d <- c("Earth","Earth","Earth","Earth","Mars")
my_data <- data.frame(letter = col_a,species = col_b,age = col_c,planet = col_d)
my_data <- datatable(my_data,colnames = c("ID","Species","Age","Home Planet"),rownames = FALSE,filter = 'top',selection = 'single',
callback = JS("table.on('click.dt','tr',function() {
Shiny.onInputChange('rows',table.rows(this).data().toArray(),{priority:'event'});});"))
return(my_data)
}
pickerinput_choices <- function(my_species){
if(my_species == "Human"){
return(c("Job","Family","Mortgage"))
}else{
return(c("Breed","Owner","Family"))
}
}
advanced_inputs <- function(my_species,my_choiceA){
if(is.null(my_choiceA)){return(0)}
if(my_choiceA == "Job"){
return(checkboxGroupInput("my_checkbox",label = "Type of Jobs",choices = c("Employed","Self-Employed","Apprenticeship")))
}else if(my_choiceA == "Mortgage"){
return(checkboxGroupInput("my_checkbox",label = "Type of Housing",choices = c("Apartment","House")))
}else if(my_choiceA == "Breed"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Height","Fur","Weight")))
}else if(my_choiceA == "Owner"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Age","Employed","Children")))
}else{
if(my_species == "Human"){
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Partner","Parents","Children","Siblings")))
}else{
return(checkboxGroupInput("my_checkbox",label = "Details",choices = c("Owner","Children","Owners of Children")))
}
}
}
Server:
server <- function(input, output,session) {
glide_modal <- modalDialog(
renderUI({title = tags$span(paste("You have chosen Row",input$rows[1]),style = "font-size: 20px; font-weight: bold")}),
footer = NULL,
easyClose = TRUE,
glide(
id = "my_glide",
controls_position = 'bottom',
height = "800px",
screen(
renderUI({
pickerInput(inputId = "my_pickerinput",h3("Make Choice A"),choices = pickerinput_choices(input$rows[2]),
options = pickerOptions(container = 'body'))
})
),
screen(
renderUI({
tagList(
h3("Make Choice B"),
advanced_inputs(input$rows[2],input$my_pickerinput)
)
}),
next_condition = "(typeof input['my_checkbox'] !== 'undefined' && input['my_checkbox'].length > 0)"
),
screen(
renderText({
paste("You have selected row",input$rows[1],"which is a",input$rows[2],"and have requested information about",
input$my_pickerinput,", especially about",paste(input$my_checkbox,collapse = " and "))
})
)
)
)
output$table <- DT::renderDataTable({
render_my_table()
})
observeEvent(input$rows,{
showModal(tags$div(id="modal1",glide_modal))
})
}
and function call:
shinyApp(ui = ui, server = server)
Fixed by the newest development version thanks to the package author. See the github thread, the code works now as posted in the question.
I have an app with two observeEvent() handlers reacting to input A and input B and doing some stuff. Among the stuff for event A, is updating input B.
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, ignoreInit = TRUE, {
message("Doing A stuff")
updateSelectInput(session, "B", selected = 10)
})
observeEvent(input$B, ignoreInit = TRUE, {
message("Doing B stuff")
})
}
)
So changing input A obviously triggers event B as well. I would like event B to be triggered only when the user is changing the value of the input and not when it is done by updateInput. Is there a way to suspend scheduling events when a expression is evaluated? I would like something like this:
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, ignoreInit = TRUE, {
message("Doing A stuff")
suspendEventScheduling()
updateSelectInput(session, "B", selected = 10)
resumeEventScheduling()
})
observeEvent(input$B, ignoreInit = TRUE, {
message("Doing B stuff")
})
}
)
Documentation for observers mentions "suspended state" but I cannot find any examples as to how to actually use it.
In the past I have used a sentinel value pattern to work around these types of situations (see below). But it always feels very fragile. Hopefully this feature request leads to better options.
library(shiny)
shinyApp(
ui = fluidPage(
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
is_server_update <- FALSE
observeEvent(input$A, {
message("Doing A stuff")
updateSelectInput(session, "B", selected = 10)
# Unchanged value doesn't trigger an invalidation
if (input$B != 10) {
is_server_update <<- TRUE
}
}, ignoreInit = TRUE)
observeEvent(input$B, {
if (is_server_update) {
is_server_update <<- FALSE
} else {
message("Doing B stuff")
}
}, ignoreInit = TRUE)
}
)
After some playing around, I put together a bit of JavaScript that should do
the trick.
The idea is to keep track of suspended inputs whose values should not
change. Using an event hook, we can then check if an input event targets
one of the suspended inputs. If so, prevent it from making changes. Crucially
though, the UI still gets updated – just not the Shiny input values.
We then also need a couple of helper functions to manage the list of
suspended inputs. Here’s the JavaScript, and the R helpers:
js <-
"
// Don't actually modify the Shiny object in 'real' code!
Shiny.suspendedInputs = new Set();
$(document).on('shiny:inputchanged', function(event) {
Shiny.suspendedInputs.has(event.target.id) && event.preventDefault();
})
Shiny.addCustomMessageHandler('suspendinput', function(message) {
Shiny.suspendedInputs.add(message.id);
});
Shiny.addCustomMessageHandler('resumeinput', function(message) {
Shiny.suspendedInputs.delete(message.id);
// Last value that Shiny got is probably out of sync with the UI
Shiny.forgetLastInputValue(message.id);
})
"
suspendInput <- function(inputId, session = getDefaultReactiveDomain()) {
session$sendCustomMessage("suspendinput", list(id = inputId))
}
resumeInput <- function(inputId, session = getDefaultReactiveDomain()) {
session$sendCustomMessage("resumeinput", list(id = inputId))
}
Almost always the suspend and resume messages should be sent on different
flush cycles. Otherwise the resume is executed before the input events from
any updates have triggered, resulting in nothing happening. Another helper
to ensure “correct” usage would be in order:
suspendForNextFlush <- function(inputId, session = getDefaultReactiveDomain()) {
session$onFlush(function() suspendInput(inputId, session = session))
session$onFlushed(function() resumeInput(inputId, session = session))
}
And now we are ready to put everything together for a working app:
library(shiny)
shinyApp(
ui = fluidPage(
tags$script(HTML(js)),
selectInput("A", "Input A", c(1:5)),
selectInput("B", "Input B", c(6:10))
),
server = function(input, output, session) {
observeEvent(input$A, {
message("Doing A stuff")
suspendForNextFlush("B")
updateSelectInput(session, "B", selected = 10)
}, ignoreInit = TRUE)
observeEvent(input$B, {
message("Doing B stuff")
}, ignoreInit = TRUE)
}
)
I would like that when user exits the selectizeInput field (clicks outside of selectizeInput), a new option is created and selected (option createOnBlur = TRUE), but I can't figure out how to control the created values to ensure they belong to the "choices" list.
In fact, I would like createOnBlur=TRUE working with create=FALSE, but this obviously doesn't work..
I have looked at selectize.js documentation and I think createFilter and/or onBlur() options could be useful but I didn't succeed in implementing it for my purpose.
Here is a reprex with an age input, I would like that when user tape e.g. "40" and then clik outside of input without pressing "Enter" (ie onBlur), the value 40 is recorded in the input, but if the user tape e.g "444", this impossible age value is not created in the list of choices :
library(shiny)
input_age <- function(mina = 0, maxa =100){
selectizeInput(inputId = "age",
label = "Age",
choices = c("choose one" = "", mina:maxa),
options = list(create = TRUE,
createOnBlur = TRUE)
)
}
ui <- shinyUI(fluidPage(
titlePanel("selectize createonblur"),
mainPanel(
input_age(mina = 20, maxa = 70)
)
))
# SERVER
server <- shinyServer(function(input, output) {
})
shinyApp(ui, server)
You can use updateSelectizeInput to check the selection made against the choices after each interaction with your input.
Please see the following:
library(shiny)
input_age <- function(mina = 0, maxa = 100){
selectizeInput(inputId = "age",
label = "Age",
choices = c("choose one" = "", mina:maxa),
options = list(create = TRUE,
createOnBlur = TRUE)
)
}
minAge <- 20
maxAge <- 70
ui <- shinyUI(fluidPage(
titlePanel("selectize createonblur"),
mainPanel(
input_age(mina = minAge, maxa = maxAge)
)
))
# SERVER
server <- shinyServer(function(input, output, session) {
observeEvent(req(input$age), {
if(length(setdiff(input$age, as.character(seq(minAge, maxAge)))) > 0){
updateSelectizeInput(session,
inputId = "age",
choices = seq(minAge, maxAge),
selected = "")
}
})
})
shinyApp(ui, server)
Update - Here is a JS approach:
library(shiny)
input_age <- function(mina = 0, maxa = 100){
selectizeInput(inputId = "age",
label = "Age",
choices = c("choose one" = "", mina:maxa),
options = list(create = TRUE,
createOnBlur = TRUE))
}
ui <- shinyUI(fluidPage(
tags$head(tags$script(HTML("
$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'age') {
if (isNaN(parseInt(event.value)) || event.value > 70 || event.value < 20) {
var $select = $('#age').selectize();
var selectize = $select[0].selectize;
selectize.setValue(null, true);
}
}
});
"))),
titlePanel("selectize createonblur"),
mainPanel(
input_age(mina = 20, maxa = 70)
)
))
# SERVER
server <- shinyServer(function(input, output, session) {
})
shinyApp(ui, server)
You can supply a regular expression to the createFilter option. If the user types something which doesn't match this regular expression, then "Add ..." will not appear and it will not be possible to add this item.
library(shiny)
ui <- fluidPage(
titlePanel("selectize createonblur"),
mainPanel(
selectizeInput(
inputId = "age",
label = "Age",
choices = c("choose one" = "", 20:70),
options = list(
create = TRUE,
createOnBlur = TRUE,
createFilter = I("/^([2-6][0-9]|70)$/")
)
)
)
)
server <- function(input, output, session) {}
shinyApp(ui, server)
Problem: I have the following app. Essentially, I want to press the button to load the data. After the first time I load the data via button press I want to get ask if I want to save my changes. If yes, confirmation that changes were successfully saved, else show some other data (other data not included).
Approach I tried to solve it with observeEvent expressions which are triggered via reactiveValues. However, as you will observe when running the script below, this does not work out as expected.
Question: Any idea on what is wrong?
library(shiny)
library(shinyWidgets)
library(rhandsontable)
shinyApp(
ui = fluidPage(
actionButton("show", "Show data", width = "100%"),
rHandsontableOutput("data_table")
),
server = function(input, output) {
rv <- reactiveValues(
# Triggers
pressed_first_time = 0,
confirm_module = TRUE,
save_module = TRUE,
table_change = TRUE
)
observeEvent(input$show, ignoreInit = TRUE, {
if (rv$pressed_first_time == 0){
rv$pressed_first_time <- isolate(rv$pressed_first_time + 1)
rv$table_change <- isolate(!rv$table_change)
cat("pressed_first time")
} else {
rv$pressed_first_time <- isolate(rv$pressed_first_time + 1)
rv$confirm_module <- isolate(!rv$confirm_module)
}
})
observeEvent(rv$confirm_module, ignoreInit = TRUE,{
confirmSweetAlert(
session = session,
inputId = session$ns("show_confirmation"),
title = "Be careful, your changes might be lost",
text = "Do you want to save your changes?",
type = "question",
btn_labels = c("Cancel", "Save"),
btn_colors = NULL,
closeOnClickOutside = FALSE,
showCloseButton = FALSE,
html = FALSE
)
cat("confirmation module")
rv$save_module <- isolate(!rv$save_module)
})
observeEvent(rv$save_module, ignoreInit = TRUE, {
if (isTRUE(input$show_confirmation)) {
sendSweetAlert(
session = session,
title = "Saved",
text = "Updated data has been successfully saved",
type = "success"
)
rv$table_change <- isolate(!rv$table_change)
cat("saving module")
} else {
return()
}
})
data_to_modify <- eventReactive(rv$table_change, ignoreInit = TRUE, {
mtcars
})
handson_df <- eventReactive(rv$table_change, ignoreInit = TRUE, {
cat("create handsons")
req(data_to_modify())
rhandsontable(data_to_modify())
})
output$data_table <- renderRHandsontable({
cat("plot module")
req(handson_df())
htmlwidgets::onRender(handson_df(),change_hook)
})
}
)
I think its just that you need session inside the server, as in:
server = function(input, output, session) {...
Actually, I found out the problem. The link from data_to_modify to handson_df was missing. In the below solution I put them together but in principle adding another reactiveValue triggering handson_df from data_to_modify will also work
library(shiny)
library(rhandsontable)
shinyApp(
ui = fluidPage(
actionButton("show", "Show data", width = "100%"),
rHandsontableOutput("data_table")
),
server = function(input, output) {
rv <- reactiveValues(
# Triggers
pressed_first_time = 0,
confirm_module = TRUE,
save_module = TRUE,
table_change = TRUE
)
observeEvent(input$show, ignoreInit = TRUE, {
if (rv$pressed_first_time == 0){
rv$pressed_first_time <- 1
rv$table_change <- isolate(!rv$table_change)
cat("pressed_first time")
} else {
rv$pressed_first_time <- 1
rv$confirm_module <- isolate(!rv$confirm_module)
}
})
observeEvent(rv$confirm_module, ignoreInit = TRUE,{
confirmSweetAlert(
session = session,
inputId = session$ns("show_confirmation"),
title = "Be careful, your changes might be lost",
text = "Do you want to save your changes?",
type = "question",
btn_labels = c("Cancel", "Save"),
btn_colors = NULL,
closeOnClickOutside = FALSE,
showCloseButton = FALSE,
html = FALSE
)
})
observeEvent(input$show_confirmation, ignoreInit = TRUE, {
if (isTRUE(input$show_confirmation)) {
sendSweetAlert(
session = session,
title = "Saved",
text = "Updated data has been successfully saved",
type = "success"
)
rv$table_change <- isolate(!rv$table_change)
cat("saving module")
} else {
return()
}
})
data_to_modify <- eventReactive(rv$table_change, ignoreInit = TRUE, {
rhandsontable(mtcars)
})
# handson_df <- eventReactive(rv$table_change, ignoreInit = TRUE, {
# cat("create handsons")
# req(data_to_modify())
# rhandsontable(data_to_modify())
# })
output$data_table <- renderRHandsontable({
cat("plot module")
req(data_to_modify())
data_to_modify()
# htmlwidgets::onRender(handson_df(),change_hook)
})
}
)
I need a reactive variable (declared server-side) available after start-up. Using what I learned here How to create a conditional renderUI in Shiny dashboard I tried wrapping in reactive() before defining the UI but no luck. Moving topValuesSelector to the UI inside a conditionalPanel would work except conditional panels apparently do not like the %in% operator (a separate issue that I also tried to resolve w/o success).
if (interactive()) {
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <-
dashboardPage(header = dashboardHeaderPlus(left_menu = tagList(
dropdownBlock(
id = "prefDropdown",
title = "Preferences",
icon = NULL,
badgeStatus = NULL,
checkboxGroupInput(
inputId = "prefDropdown",
label = NULL,
choices = c("Pareto",
"Legend on chart",
"Cases/1K uniques",
"Top 10 only"),
selected = c("Pareto", "Cases/1K uniques", "Top 10 only")
),
uiOutput("topValues")
)
)),
dashboardSidebar(),
dashboardBody(fluidRow(box(
title = "Top",
textOutput("topN")
))))
server <- function(input, output) {
topValuesSelector <- reactive({
if ("Top 10 only" %in% input$prefDropdown) {
numericInput(
inputId = "topValues",
label = NULL,
width = "25%",
value = 10,
min = 1,
max = 30,
step = 1
)
}
})
output$topValues <- renderUI({
topValuesSelector()
})
observe({
if ("Top 10 only" %in% input$prefDropdown) {
output$topN <- renderText(input$topValues)
} else{
output$topN <- renderText(100)
}
})
}
shinyApp(ui, server)
}
The intent is for the initial value of "topValues" to be 10 with this value immediately available. However, no value is available which causes an error. Using req() avoids the error by pausing execution but that is not a viable approach because "topValues" is needed for a plot. So no plot until selecting "prefDropdown".
It looks like the problem is that input$topValues does not exist until you click on the Preferences button. Since the UI element isn't needed it hasn't been created yet.
In order to work around that you can create a variable that detects whether or not the input is available and if not use a default value.
if (interactive()) {
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
ui <-
dashboardPage(header = dashboardHeaderPlus(left_menu = tagList(
dropdownBlock(
id = "prefDropdown",
title = "Preferences",
icon = NULL,
badgeStatus = NULL,
checkboxGroupInput(
inputId = "prefDropdown",
label = NULL,
choices = c("Pareto",
"Legend on chart",
"Cases/1K uniques",
"Top 10 only"),
selected = c("Pareto", "Cases/1K uniques", "Top 10 only")
),
uiOutput("topValues")
)
)),
dashboardSidebar(),
dashboardBody(fluidRow(box(
title = "Top",
textOutput("topN")
))))
server <- function(input, output) {
## We want to use the same default value in two places so create a var
default_value <- 10
topValuesSelector <- reactive({
if ("Top 10 only" %in% input$prefDropdown) {
numericInput(
inputId = "topValues",
label = NULL,
width = "25%",
value = default_value, ## Change to use the default value
min = 1,
max = 30,
step = 1
)
}
})
output$topValues <- renderUI({
topValuesSelector()
})
## Create a variable that is the default value unless the input is available
myTopN <- reactive({
if(length(input$topValues)>0){
return(input$topValues)
}
return(default_value)
})
observe({
if ("Top 10 only" %in% input$prefDropdown) {
# output$topN <- renderText(input$topValues)
output$topN <- renderText(myTopN()) ## Use our new variable instead of the input directly
} else{
output$topN <- renderText(100)
}
})
}
shinyApp(ui, server)
}
There are a couple of other things going on with your code. Notice that "Top 10 only" %in% input$prefDropdown will not do what you think it is doing. You have to check to see if "Top 10 only" is TRUE... I'll leave you there to start another question if you get stuck again.