I am trying to create a Shiny App based on modules and I need to add a highchart inside a module where the graph updates when the user selects a value from a selectInput dropdown. The idea is that when the user select a value from a selectInput box in the UI, this filters a dataset and then the highchart is updated. The problem is that I am not able to pass the filtered dataset to the myModuleServer (see below). How can I do this?
This is the dataset:
df <- data.frame(label = c('A','B'), value = c(10,25))
These are the modules UI and Server:
myModuleUI <- function(id) {
ns <- NS(id)
tagList(
textOutput(ns("title")),
textOutput(ns("text")),
highchartOutput(ns("graph")))}
myModuleServer <- function(input, output, session, action, dataset) {
output$title <- renderText({paste0("You selected letter: ",action())})
output$text <- renderText({paste0("In the dataset the letter selected corresponds to number: ", dataset()$value)})
output$graph <- renderHighchart({hchart(dataset(), 'bar', hcaes(x=dataset()$label, y=dataset()$value))})
}
Below both the UI and Server components of a Shiny App:
ui <- fluidPage(
fluidRow(
column(width = 3, wellPanel(selectInput('dummy', 'Select a letter', choices = c('A', 'B')))),
column(width = 6, myModuleUI("module1")))
)
server <- function(input, output, session) {
reactiveData <- reactive({input$dummy})
reactiveDataSet <- reactive({df %>% filter(label == input$dummy)})
callModule(myModuleServer, 'module1', action = reactiveData, dataset = reactiveDataSet)
}
shinyApp(ui, server)
Related
I am building a shiny app with a selectize input.
The choices in the input are dependent upon the ids in the underlying data.
In my real app, the data updates with a call to an API.
I would like the selected id choice in the selectize input to hold constant when I hit the "update data" button.
I was able to do this prior to using shiny modules. However, when I tried to transform my code to use a shiny module, it fails to hold the selected id value, and resets the selectize input each time I update the underlying data.
The following example was helpful without the module, but when I use the module it doesn't seem to work...link here
Below is a reprex. Thanks for any help.
library(shiny)
library(tidyverse)
# module UI
mymod_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(ns("ids_lookup")),
)
}
# module server
mymod_server <- function(input, output, session, data, actionb){
ns <-session$ns
ids <- reactive(
data() %>%
filter(!is.na(first_name) & !is.na(last_name) & !is.na(ages)) %>%
mutate(ids = paste(first_name, last_name, sep = " ")) %>%
select(ids)
)
output$ids_lookup <- renderUI({
selectizeInput(ns("lookup"),
label = "Enter id:",
choices = c("Type here ...", ids()), multiple = FALSE)
})
# here is where I would like to hold on to the selected ids when updating the table
# when I click the "reload_data" button I don't want the name to change
# I pass the button from the main server section into the module
current_id_selection <- reactiveVal("NULL")
observeEvent(actionb(), {
current_id_selection(ns(input$ids_lookup))
updateSelectizeInput(session,
inputId = ns("lookup"),
choices = ids(),
selected = current_id_selection())
})
}
ui <- fluidPage(
titlePanel("Test module app"),
br(),
# this button reloads the data
actionButton(
inputId = "reload_data",
label = "Reload data"
),
br(),
br(),
# have a look at the data
h4("Raw data"),
tableOutput("mytable"),
br(),
# now select a single id for further analysis in a much larger app
mymod_ui("mymod"),
)
server <- function(input, output, session) {
df <- eventReactive(input$reload_data, {
# in reality, df is a dataframe which is updated from an API call everytime you press the action button
df <- tibble(
first_name = c("john", "james", "jenny", "steph"),
last_name = c("x", "y", "z", NA),
ages = runif(4, 30, 60)
)
return(df)
}
)
output$mytable <- renderTable({
df()
})
# make the reload data button a reactive val that can be passed to the module for the selectize Input
mybutton <- reactive(input$reload_data)
callModule(mymod_server, "mymod", data = df, actionb = mybutton)
}
shinyApp(ui, server)
Just using inputId = "lookup" instead of inputId = ns("lookup") in updateSelectizeInput() will do it. Also, you had another typo in there. Try this
library(shiny)
library(tidyverse)
# module UI
mymod_ui <- function(id){
ns <- NS(id)
tagList(
uiOutput(ns("ids_lookup")),
verbatimTextOutput(ns("t1"))
)
}
# module server
mymod_server <- function(input, output, session, data, actionb){
ns <-session$ns
ids <- reactive(
data() %>%
filter(!is.na(first_name) & !is.na(last_name) & !is.na(ages)) %>%
mutate(ids = paste(first_name, last_name, sep = " ")) %>%
select(ids)
)
output$ids_lookup <- renderUI({
selectizeInput(ns("lookup"),
label = "Enter id:",
choices = c("Type here ...", ids()), multiple = FALSE)
})
# here is where I would like to hold on to the selected ids when updating the table
# when I click the "reload_data" button I don't want the name to change
# I pass the button from the main server section into the module
current_id_selection <- reactiveValues(v=NULL)
observeEvent(actionb(), {
req(input$lookup)
current_id_selection$v <- input$lookup
output$t1 <- renderPrint(paste0("Current select is ",current_id_selection$v))
updateSelectizeInput(session,
inputId = "lookup",
choices = ids(),
selected = current_id_selection$v )
})
}
ui <- fluidPage(
titlePanel("Test module app"),
br(),
# this button reloads the data
actionButton(inputId = "reload_data", label = "Reload data"
),
br(),
br(),
# have a look at the data
h4("Raw data"),
tableOutput("mytable"),
br(),
# now select a single id for further analysis in a much larger app
mymod_ui("mymod")
)
server <- function(input, output, session) {
df <- eventReactive(input$reload_data, {
# in reality, df is a dataframe which is updated from an API call everytime you press the action button
df <- tibble(
first_name = c("john", "james", "jenny", "steph"),
last_name = c("x", "y", "z", NA),
ages = runif(4, 30, 60)
)
return(df)
})
output$mytable <- renderTable({
df()
})
# make the reload data button a reactive val that can be passed to the module for the selectize Input
mybutton <- reactive(input$reload_data)
callModule(mymod_server, "mymod", data = df, actionb = mybutton)
}
shinyApp(ui, server)
I am currently modularizing a Shiny app in different modules following the {golem} framework. For simplicity, let's say I have 3 main shiny modules:
mod_faith_plot: generates a scatterplot of a given dataset (I'll use faitfhul).
mod_points_select: decouples a dropdown menu to select how many points will be plotted. UI inputs have this dedicated module as I wanted to place the selector in the sidebarPanel instead of mainPanel (alongside the plot).
mod_data: provides a reactive dataframe depending on the n_points argument.
This modules talk to each other in the server function.
Now, when I start my app with a simple head(., n_points()) in mod_data I get the following warning:
Warning: Error in checkHT: invalid 'n' - must contain at least one non-missing element, got none.
The input in mod_points_select is clearly NULL before the selected_points argument gets assigned, is there a less hacky and more elegant way to avoid the warning at startup than my if condition?
library(shiny)
library(dplyr)
library(ggplot2)
# [Module] Plot faithful data -------------------------------------------------------
mod_faith_plot_ui <- function(id){
ns <- NS(id)
tagList(
plotOutput(ns("faith_plot"))
)
}
mod_faith_plot_server <- function(input, output, session, data){
ns <- session$ns
output$faith_plot <- renderPlot({
data() %>%
ggplot(aes(eruptions, waiting)) +
geom_point()
})
}
# [Module] Module for n_points dropdown ---------------------------------------------
mod_points_select_ui <- function(id){
ns <- NS(id)
uiOutput(ns("select_points"))
}
mod_points_select_server <- function(input, output, session){
ns <- session$ns
output$select_points <- renderUI({
selectInput(
ns("n_points"),
label = "Select how many points",
choices = seq(0, 200, by = 10),
selected = 50
)
})
reactive({input$n_points})
}
# [Module] Get filtered data -----------------------------------------------------------------
mod_data_server <- function(input, output, session, n_points){
ns <- session$ns
data <- reactive({
faithful %>%
# If condition used to avoid warnings at startup - switch lines to get warning
# head(., n_points())
head(., if(is.null(n_points())) { TRUE } else {n_points()})
})
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
mod_points_select_ui(id = "selected_points")
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("plot", mod_faith_plot_ui(id = "faith_plot"))
)
)
)
)
server <- function(input, output, session) {
data <- callModule(mod_data_server, id = "data", n_points = selected_points)
selected_points <- callModule(mod_points_select_server, id = "selected_points")
callModule(mod_faith_plot_server, id = "faith_plot", data = data)
}
shinyApp(ui, server)
You can use req() to ensure values are available:
data <- reactive({
req(n_points())
faithful %>%
head(., n_points())
})
When values are not available the call is silently canceled
I have a shiny app where I want to allow the user to select a dataset based on a set of uploaded files and then specify the columns to display from the selected dataset. If I leave some columns selected and then switch datasets, an error flashes and is output to the console stating that the selected columns are unknown before the app switches datasets and displays it correctly. In my full app however, the app crashes, though I wasn't able to figure out how to reproduce the crash. I thought it might be related to some preprocessing that is done to add additional columns which are the same across datasets and which remain selected, but the error is the same without that feature.
library(shiny)
library(tidyverse)
library(DT)
ui <- fluidPage(
checkboxGroupInput("select_var", label = "Select Variables"),
selectInput("dataset", label = NULL, choices = c("mtcars", "rock")),
DT::dataTableOutput("table")
)
server <- function(session, input, output) {
# define the dataset
data <- reactive({switch(input$dataset,"rock" = rock,"mtcars" = mtcars)})
# add a common column name that is always selected
dataprocessed <- reactive({data <- data()
data$num <- seq(1:nrow(data))
return(data)})
# dynamically generate the variable names
observe({
vchoices <- names(dataprocessed())
updateCheckboxGroupInput(session, "select_var", choices = vchoices, selected = c("num"))
})
# select the variables based on checkbox
data_sel <- reactive({
req(input$select_var)
df_sel <- dataprocessed() %>% select(input$select_var)
})
output$table <- DT::renderDataTable(data_sel())
}
# Run the application
shinyApp(ui = ui, server = server)
We can add a conditional requirement using req() to test for column existence before rendering:
library(shiny)
library(tidyverse)
library(DT)
ui <- fluidPage(
checkboxGroupInput("select_var", label = "Select Variables"),
selectInput("dataset", label = NULL, choices = c("mtcars", "rock")),
DT::dataTableOutput("table")
)
server <- function(session, input, output) {
# define the dataset
data <- reactive({
switch(input$dataset,"rock" = rock,"mtcars" = mtcars)
})
# add a common column name that is always selected
dataprocessed <- reactive({
data <- data()
data$num <- seq(1:nrow(data))
return(data)
})
# dynamically generate the variable names
observe({
vchoices <- names(dataprocessed())
updateCheckboxGroupInput(session, "select_var", choices = vchoices, selected = c("num"))
})
# select the variables based on checkbox
data_sel <- reactive({
req(input$select_var)
req(names(dataprocessed()) %in% input$select_var)
a <- names(dataprocessed())[names(dataprocessed()) %in% input$select_var]
df_sel <- dataprocessed() %>% select(a)
})
output$table <- DT::renderDataTable(data_sel())
}
# Run the application
shinyApp(ui = ui, server = server)
I've have tried lots of combinations of this to no avail and am all out of ideas.
I have a data.table, DT, and a shiny app with two selectInputs both based off of the same shiny module.
The first inputSelect should subset my data.table based on the first column and the second takes the remaining subset and subsets DT further based on the values of the second column.
I am finding it impossible to make the choices for the second selectInput to be the values from the second column after the subset where the 1st selectInput == col1.
I have included example code for the app below. The actual app I am making is more complicated than this. Everything works up until the second selectInput. I am having problems making this second renderUI reactive.
Would very much appreciate some tips in the right direction.
library(data.table)
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
ui <- pageWithSidebar(headerPanel = headerPanel(title = "title"),
sidebarPanel = sidebarPanel(
myUI('menu1')
,
myUI('menu2')
),
mainPanel = mainPanel(actionButton("debug","INSPECT"))
)
set.seed(1)
DT <- data.table(col1 = LETTERS[rep(1:2, each = 3)] ,
col2 = LETTERS[sample(1:4, 6, replace = TRUE)],
num = 1:6,
key = c("col1", "col2"))
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
if(text == "textArg1"){
selectInput(paste0(text,"Val"),"choose",choices = DT[,col1])
}else{
selectInput(paste0(text,"Val"),"choose",choices = DT[col1 == input$textArg1Val,col2])
}
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'menu1', session = session, 'textArg1')
callModule(myTextFunc, 'menu2', session = session, 'textArg2')
observeEvent(input$debug,
browser()
)
}
shinyApp(ui = ui, server = server)
You can add some reactive data manualy
like
myTextFunc <- function(input, output, session, text,data) {
output$myFinalText <- renderUI({
if(text == "textArg1"){
selectInput(paste0(text,"Val"),"choose",choices = DT[,col1])
}else{
selectInput(paste0(text,"Val"),"choose",choices = DT[col1 == data(),col2])
}
})
}
server <- function(input, output, session) {
reactive_choose=reactive({
input$textArg1Val
})
callModule(myTextFunc, 'menu1', 'textArg1')
callModule(myTextFunc, 'menu2', 'textArg2',reactive_choose)
}
In figuring out how to use the new shiny modules, I would like to emulate the following app. When the rows of the datatable are clicked and unclicked, it updates the entries in the selectInput box, using updateSelectInput.
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput('car_input', 'Select car:', df$model, multiple = TRUE)
),
mainPanel(
DT::dataTableOutput('table')
)
)
)
server <- function(input, output, session, ...) {
output$table <- DT::renderDataTable(df)
car_rows_selected <- reactive(car_names[input$table_rows_selected, ])
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
I have got most of the way there, but am having difficulty with updating the input box. I wonder if it has something to do with the way the namespaces work, and perhaps requires a nested call to the DFTable module within the Car module, but I'm not sure. I am able to add a textOutput element that prints the expected information from the selected table rows. My code for a single file app is below:
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
# I was thinking perhaps I needed to call the DFTable module as a nested module within this Car module
car_rows_selected <- callModule(DFTable, 'id_inner')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
return(reactive(car_names[input$table_rows_selected, ]))
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car'),
textOutput('selected') # NB. this outputs expected values
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
callModule(DFTable, 'id_table')
output$selected <- callModule(DFTable, 'id_table') # NB this works as expected (see textOutput in ui section above)
car_rows_selected <- callModule(DFTable, 'id_table')
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
shinyApp(ui = ui, server = server)
Any help would be greatly appreciated
OK, a little more trial and error got me to the right answer - the car_rows_selected item needed to be given the double arrow <<- operator in the app server function in order for it to be useable in the Car module: look for the car_rows_selected <<- callModule(DFTable, 'id_table') in the server function
library(shiny)
## prepare dataframe -----------------------------------------------------------
df <- mtcars
df$model <- rownames(df)
rownames(df) <- NULL
df <- df[1:10, c(12, 1:5)]
car_names <- data.frame(df$model)
## select module ---------------------------------------------------------------
CarInput <- function(id){
ns <- NS(id)
selectInput(ns('car_input'), 'Select car:', df$model, multiple = TRUE)
}
Car <- function(input, output, session, ...) {
observe({ updateSelectInput(session, 'car_input', selected = car_rows_selected()) })
}
## datatable module ------------------------------------------------------------
DFTableOutput <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('table'))
}
DFTable <- function(input, output, session, ...){
output$table <- DT::renderDataTable(df)
reactive(car_names[input$table_rows_selected, ])
}
## app -------------------------------------------------------------------------
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
CarInput('id_car')
),
mainPanel(
DFTableOutput('id_table')
)
)
)
server <- function(input, output, session, ...) {
callModule(Car, 'id_car')
car_rows_selected <<- callModule(DFTable, 'id_table')
}
shinyApp(ui = ui, server = server)
I'm still getting my head around the way module namespaces work - perhaps this isn't the most "correct" approach but at least it works - happy to accept a more appropriate answer if someone posts one later