updateSelectInput is overwritten by a selectInput in a shiny app - r

In the example below the action button would update the select input values. However, the second selection input is dependent on the first one and when the action button is selected the update to "virginica" does not occur.
ui <- fluidPage(
actionButton(inputId = "action", label = "click"),
uiOutput("select_col"),
uiOutput("select_species")
)
#
server <- function(input, output) {
output$select_col <- renderUI({
selectInput(inputId = "select_col",
label = "select_col",
choices = colnames(iris))
})
output$select_species <- renderUI({
selectInput(inputId = "select_species",
label = "Species",
choices = unique(iris[ ,input$select_col]))
})
observeEvent(input$action, {
updateSelectInput(inputId = "select_col", selected = "Species")
updateSelectInput(inputId = "select_species", selected = "virginica")
})
}
# Run the application
shinyApp(ui = ui, server = server)
I expect the following result:
'Species'in selectinput 'select_col' and setosa in selectinput 'Species'


That should work:
xxx <- reactiveVal(NULL)
observeEvent(input$action, {
updateSelectInput(inputId = "select_col", selected = "Species")
xxx(TRUE)
})
observeEvent(xxx(), {
updateSelectInput(inputId = "select_species", selected = "virginica")
xxx(NULL)
})
EDIT
No that doesn't work. Here is a solution using the delay function of the shinyjs package:
observeEvent(input$action, {
updateSelectInput(inputId = "select_col", selected = "Species")
delay(0, updateSelectInput(inputId = "select_species", selected = "virginica"))
})
Don't forget:
library(shiny)
library(shinyjs)
ui <- fluidPage(
useShinyjs(), # <- don't forget that
actionButton(inputId = "action", label = "click"),
......

Related

In R/Shiny how to make inputs have the same name of actionButton

I have a code that once I click on the option of my selectInput widget the input value is the names that are showed on the options.
I would like to make the same thing with my actionLink button but the input in this case is the sum of clicks. Is it possible to change the inputs values?
This is my code:
library(shiny)
library(dplyr)
library(purrr)
ui <- fluidPage(
tags$div(
id = "sidebar",
class = "sidebar",
selectInput(
inputId = "custom_select",
label = "Clubs",
choices = names(mtcars),
selectize = F,
size = 5,
width = "300px"
),
div(
names(mtcars) %>% map(~.x %>% actionLink(inputId = .x)))
),
h1(htmlOutput(outputId = 'title')),
h1(htmlOutput(outputId = 'title2')))
server <- function(input, output, session) {
output$title <- renderUI({
input$custom_select
})
output$title2 <- renderUI({
input[[names(mtcars)[1]]]
})
}
shinyApp(ui, server)
As you can see the output is the number of clicks.
For the selectInput widget it works fine.
Any help?

Not sure whether I got you right but using an observeEvent you could do:
library(shiny)
library(dplyr)
library(purrr)
ui <- fluidPage(
tags$div(
id = "sidebar",
class = "sidebar",
selectInput(
inputId = "custom_select",
label = "Clubs",
choices = names(mtcars),
selectize = F,
size = 5,
width = "300px"
),
div(
names(mtcars) %>% map(~ .x %>% actionLink(inputId = .x))
)
),
h1(htmlOutput(outputId = "title")),
h1(htmlOutput(outputId = "title2"))
)
server <- function(input, output, session) {
output$title <- renderUI({
input$custom_select
})
lapply(names(mtcars), function(x) {
observeEvent(input[[x]], {
output$title2 <- renderUI({
paste(x, input[[x]], sep = ": ")
})
})
})
}
shinyApp(ui, server)

R shiny: insertUI and observeEvent in module

Using the diamonds dataset as an example, after a button is pressed, two pickerInput should appear.
In the first one, the user chooses between three columns of the diamonds dataset. Once a value is selected the app should update the choices of the second pickertInput based on the unique values of the selected column.
The app works well without modularizing it. After reading couple of discussions about modules, I still don't clearly understand how to properly declare reactive values for accessing the different input$....
MODULE
module.UI <- function(id){
ns <- NS(id)
actionButton(inputId = ns("add"), label = "Add")
}
module <- function(input, output, session, data, variables){
ns <- session$ns
observeEvent(input$add, {
insertUI(
selector = "#add",
where = "beforeBegin",
ui = fluidRow(
pickerInput(inputId = "picker_variable",
choices = variables,
selected = NULL
),
pickerInput(inputId = "picker_value",
choices = NULL,
selected = NULL
)
)
)
})
observeEvent(input$picker_variable,{
updatePickerInput(session,
inputId = "picker_value",
choices = as.character(unlist(unique(data[, input$picker_variable]))),
selected = NULL
)
})
}
APP
ui <- fluidPage(
mainPanel(
module.UI(id = "myID")
)
)
server <- function(input, output, session) {
callModule(module = module, id = "myID", data = diamonds, variables=c("cut", "color", "clarity"))
}
shinyApp(ui = ui, server = server)
EDIT
User should be able to click the button more than once in order to create several pickerInput pairs.
EDIT #2
Based on #starja code, trying to return the values of the 2 pickers leads to a NULL object.
library(shiny)
library(shinyWidgets)
library(ggplot2)
module.UI <- function(id, variables){
ns <- NS(id)
ui = fluidRow(
pickerInput(inputId = ns("picker_variable"),
choices = variables,
selected = NULL
),
pickerInput(inputId = ns("picker_value"),
choices = NULL,
selected = NULL
)
)
}
module <- function(input, output, session, data, variables){
module_out <- reactiveValues(variable=NULL, values=NULL)
observeEvent(input$picker_variable,{
updatePickerInput(session,
inputId = "picker_value",
choices = as.character(unlist(unique(data[, input$picker_variable]))),
selected = NULL
)
})
observe({
module_out$variable <- input$picker_variable
module_out$values <- input$picker_value
})
return(module_out)
}
ui <- fluidPage(
mainPanel(
actionButton(inputId = "add",
label = "Add"),
tags$div(id = "add_UI_here")
)
)
list_modules <- list()
current_id <- 1
server <- function(input, output, session) {
observeEvent(input$add, {
new_id <- paste0("module_", current_id)
list_modules[[new_id]] <<-
callModule(module = module, id = new_id,
data = diamonds, variables = c("cut", "color", "clarity"))
insertUI(selector = "#add_UI_here",
ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
current_id <<- current_id + 1
})
req(input$list_modules)
print(list_modules)
}
shinyApp(ui = ui, server = server)
EDIT #3
Still having difficulties to return the values of the 2 pickers in a list that would be convenient to access further (example below):
module_out
$module_1
$module_1$variable
[1] "cut"
$module_1$values
[1] "Ideal" "Good"
$module_2
$module_2$variable
[1] "color"
$module_2$values
[1] "E" "J"

Your code has 2 issues:
if you insert UI elements in a module via insertUI, the ids of the UI elements need to have the correct namespace: ns(id)
because the id you use in the selector of insertUI was created in the module, it is also namespaced, so the selector argument also has to be namespaced
library(shiny)
library(shinyWidgets)
library(ggplot2)
module.UI <- function(id){
ns <- NS(id)
actionButton(inputId = ns("add"), label = "Add")
}
module <- function(input, output, session, data, variables){
ns <- session$ns
observeEvent(input$add, {
insertUI(
selector = paste0("#", ns("add")),
where = "beforeBegin",
ui = fluidRow(
pickerInput(inputId = ns("picker_variable"),
choices = variables,
selected = NULL
),
pickerInput(inputId = ns("picker_value"),
choices = NULL,
selected = NULL
)
)
)
})
observeEvent(input$picker_variable,{
updatePickerInput(session,
inputId = "picker_value",
choices = as.character(unlist(unique(data[, input$picker_variable]))),
selected = NULL
)
})
}
ui <- fluidPage(
mainPanel(
module.UI(id = "myID")
)
)
server <- function(input, output, session) {
callModule(module = module, id = "myID", data = diamonds, variables=c("cut", "color", "clarity"))
}
shinyApp(ui = ui, server = server)
BTW: I feel that a more natural way to modularise your code would be that the Add button is in the main app and then dynamically inserts an instance of your module, so that your module only contains the logic/UI for one combination picker_variable/picker_value
Edit
Thanks for your remark. In fact, it doesn't make much sense to create several pickerInput in the module with the same inputId. I've changed my code to reflect the pattern that the actionButton is in the main app and every module only contains one set of inputs:
library(shiny)
library(shinyWidgets)
library(ggplot2)
module.UI <- function(id, variables){
ns <- NS(id)
ui = fluidRow(
pickerInput(inputId = ns("picker_variable"),
choices = variables,
selected = NULL
),
pickerInput(inputId = ns("picker_value"),
choices = NULL,
selected = NULL
)
)
}
module <- function(input, output, session, data, variables){
observeEvent(input$picker_variable,{
updatePickerInput(session,
inputId = "picker_value",
choices = as.character(unlist(unique(data[, input$picker_variable]))),
selected = NULL
)
})
}
ui <- fluidPage(
mainPanel(
actionButton(inputId = "add",
label = "Add"),
tags$div(id = "add_UI_here")
)
)
list_modules <- list()
current_id <- 1
server <- function(input, output, session) {
observeEvent(input$add, {
new_id <- paste0("module_", current_id)
list_modules[[new_id]] <<-
callModule(module = module, id = new_id,
data = diamonds, variables = c("cut", "color", "clarity"))
insertUI(selector = "#add_UI_here",
ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
current_id <<- current_id + 1
})
}
shinyApp(ui = ui, server = server)
Edit 2
You can directly return the input from the module and use this in a reactive context in the main app:
library(shiny)
library(shinyWidgets)
library(ggplot2)
module.UI <- function(id, variables){
ns <- NS(id)
ui = fluidRow(
pickerInput(inputId = ns("picker_variable"),
choices = variables,
selected = NULL
),
pickerInput(inputId = ns("picker_value"),
choices = NULL,
selected = NULL
)
)
}
module <- function(input, output, session, data, variables){
observeEvent(input$picker_variable,{
updatePickerInput(session,
inputId = "picker_value",
choices = as.character(unlist(unique(data[, input$picker_variable]))),
selected = NULL
)
})
return(input)
}
ui <- fluidPage(
mainPanel(
actionButton(inputId = "print", label = "print inputs"),
actionButton(inputId = "add",
label = "Add"),
tags$div(id = "add_UI_here")
)
)
list_modules <- list()
current_id <- 1
server <- function(input, output, session) {
observeEvent(input$add, {
new_id <- paste0("module_", current_id)
list_modules[[new_id]] <<-
callModule(module = module, id = new_id,
data = diamonds, variables = c("cut", "color", "clarity"))
insertUI(selector = "#add_UI_here",
ui = module.UI(new_id, variables = c("cut", "color", "clarity")))
current_id <<- current_id + 1
})
observeEvent(input$print, {
lapply(seq_len(length(list_modules)), function(i) {
print(names(list_modules)[i])
print(list_modules[[i]]$picker_variable)
print(list_modules[[i]]$picker_value)
})
})
}
shinyApp(ui = ui, server = server)

Add and Remove elements in Shiny

The code worked only when I added variables and removed for the first time. After I removed that variable, it went back to the select "Add to the plot", then I couldn't add it back, I think when I updated updateSelectInput, there is something wrong. Plus selectRemove needed to remove when it NULL. How I can update by both ways?
library(shiny)
mtcars_1 <- mtcars[,c("mpg", "disp", "hp", "drat", "wt", "qsec")]
runApp(list(
ui=pageWithSidebar(headerPanel("Adding and Removing Variables"),
sidebarPanel(
selectInput(inputId = "selectAdd", label = "Add to the plot",
choices = c(names(mtcars_1)),
selected = names(mtcars_1)[1]),
actionButton(inputId = "add", label = "Add to the plot")
),
mainPanel(
textOutput("text"),hr(),
uiOutput("remove_list")
)
),
server=function(input, output, session) {
rv <- reactiveValues(add_v = c())
observeEvent(input$add,{
rv$add_v <- rbind(rv$add_v,input$selectAdd)
})
rv <- reactiveValues(rem_v = c())
observeEvent(input$remove,{
rv$rem_v <- rbind(rv$rem_v,input$selectRemove)
})
observe({
value_add <- c(names(mtcars_1)[!names(mtcars_1) %in% rv$add_v ],rv$rem_v)
value_rem <-c(rv$add_v[! rv$add_v %in% rv$rem_v])
updateSelectInput(session,"selectAdd",choices = value_add)
updateSelectInput(session,"selectRemove",choices = value_rem)
})
output$remove_list <- renderUI({
if(length(rv$add_v) > 0){
tagList(
selectInput(inputId = "selectRemove", label = "Remove to the plot",
choices = c(rv$add_v),
selected = rv$add_v[1]),
actionButton(inputId = "remove", label = "Remove to the plot")
)
}
})
output$text <- renderText({
c(rv$add_v[! rv$add_v %in% rv$rem_v])
})
}))

Welcome to stackoverflow!
You were almost there - however, your updating logic for the reactiveValues wasn't complete. For each button click you'll have to add an object to one value and remove it from the other. Please check the following:
library(shiny)
mtcars_1 <- mtcars[, c("mpg", "disp", "hp", "drat", "wt", "qsec")]
runApp(list(
ui = pageWithSidebar(
headerPanel("Adding and Removing Variables"),
sidebarPanel(
selectInput(
inputId = "selectAdd",
label = "Add to the plot",
choices = names(mtcars_1),
selected = names(mtcars_1)[1]
),
actionButton(inputId = "add", label = "Add to the plot")
),
mainPanel(textOutput("text"), hr(),
uiOutput("remove_list"))
),
server = function(input, output, session) {
rv <- reactiveValues(add_v = NULL, rem_v = names(mtcars_1))
observeEvent(input$add, {
rv$rem_v <- setdiff(rv$rem_v, input$selectAdd)
rv$add_v <- union(rv$add_v, input$selectAdd)
})
observeEvent(input$remove, {
rv$add_v <- setdiff(rv$add_v, input$selectRemove)
rv$rem_v <- union(rv$rem_v, input$selectRemove)
})
observe({
updateSelectInput(session, "selectAdd", choices = rv$rem_v)
updateSelectInput(session, "selectRemove", choices = rv$add_v)
})
output$remove_list <- renderUI({
if (length(rv$add_v) > 0) {
tagList(
selectInput(
inputId = "selectRemove",
label = "Remove to the plot",
choices = c(rv$add_v),
selected = rv$add_v[1]
),
actionButton(inputId = "remove", label = "Remove to the plot")
)
}
})
output$text <- renderText({
c(rv$add_v[!rv$add_v %in% rv$rem_v])
})
}
))

Is it possible to clear the displayed output in ShinyApp using actionButton

I'm building a shinyApp on mtcars data. I got 2 actionButtons (Go & Clear).
The Go button is for displaying the output on mainPanel whereas the Clear button is for clearing that output.
My Clear button isn't working due to some unforeseen reason. Can somebody please have a look at my codes. I shall be extremely grateful.
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
DT::dataTableOutput('mytable') )))
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
# thedata <- eventReactive(input$reset,{
# data_table<-NULL
# })
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)

insertUI() and removeUI() is what you might be looking for.
Removing the element is easier with removeUI():
observeEvent(input$reset, {
removeUI("#mytable")
})
To avoid that you dont delete it permanently you could use insertUI():
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
In order to place the element correctly you can use a placeholder in the mainPanel():
mainPanel(
tags$div(id = "placeholder")
)
Then you could remove the dependency of thedata() from the input button, since you use the insertUI() now. (You should swith to insertUI(), because otherwise you cant re-insert the table once its deleted without it,...)
thedata <- reactive({
...
})
Full example would read:
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
tags$div(id = "placeholder")
)
)
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- reactive({
input$go
isolate({
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
return(data_table)
})
})
observeEvent(input$reset, {
removeUI("#mytable")
})
observeEvent(input$go, {
insertUI("#placeholder", "afterEnd", ui = DT::dataTableOutput('mytable'))
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)
)

Why not inject some javascript? This way, your code is kept virtually unchanged.
Create a js file in your shiny folder with the following code (rmDt.js in this example):
$("#reset").click(function() {
$(".display.dataTable.no-footer").DataTable().destroy();
$(".display.dataTable.no-footer").DataTable().clear().draw();
$(".display.no-footer").DataTable().destroy();
$(".display.no-footer").DataTable().clear().draw();
});
Save this file and then inject it in your shiny R script:
library(shiny)
library(DT)
library(dplyr)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear"),
includeScript(path ="rmDt.js") # inject javascript
),
mainPanel(
DT::dataTableOutput('mytable') ))
)
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server, options = list(launch.browser = T))

Unable to clear the displayed output in ShinyApp using actionButton

I'm building a shinyApp on mtcars data. I got 2 actionButtons (Go & Clear).
The Go button is for displaying the output on mainPanel whereas the Clear button is for clearing that output.
My Clear button isn't working due to some unforeseen reason. Can somebody please have a look at my codes. I shall be extremely grateful.
library(shiny)
library(DT)
library(dplyr)
library(shinythemes)
library(htmlwidgets)
library(shinyWidgets)
library(shinydashboard)
data_table<-mtcars
#ui
ui = fluidPage(
sidebarLayout(
sidebarPanel (
uiOutput("cyl_selector"),
uiOutput("disp_selector"),
actionButton(inputId = "go", label = "Go"),
actionButton(inputId = "reset", label = "Clear")),
mainPanel(
DT::dataTableOutput('mytable') )))
#server
server = function(input, output, session) {
output$cyl_selector <- renderUI({
selectInput(inputId = "cyl",
label = "cyl:", multiple = TRUE,
choices = c( unique(as.character(data_table$cyl))),
selected = c('4')) })
output$disp_selector <- renderUI({
available <- data_table[c(data_table$cyl %in% input$cyl ), "disp"]
selectInput(
inputId = "disp",
label = "disp:",
multiple = TRUE,
choices = c('All',as.character(unique(available))),
selected = 'All') })
thedata <- eventReactive(input$go,{
data_table<-data_table[data_table$cyl %in% input$cyl,]
if(input$disp != 'All'){
data_table<-data_table[data_table$disp %in% input$disp,]
}
data_table
})
# thedata <- eventReactive(input$reset,{
# data_table<-NULL
# })
output$mytable = DT::renderDataTable({
DT::datatable( filter = "top", rownames = FALSE, escape = FALSE,
options = list(pageLength = 50, autowidth=FALSE,
dom = 'Brtip' ),
{
thedata() # Call reactive thedata()
})
})}
shinyApp(ui = ui, server = server)

I didn't analyze your script completly, but i can see that it doesn't call the second button at all (Clear). You made an eventReactive() using input$go for the first button to make the plot, but you need to call input$reset too if you want to make it work.

Resources