R Shiny module: input not updated with uiOutput / renderUI inside callModule - r

I've been searching around and cannot find an answer to my question. I've constructed a simple app to demonstrate my problem. Basically, the problem is that I am trying to use a renderUI inside my module server to conditionally create a uiOutput in the module UI. I've included a few print statements that lead me to believe that the renderUI is evaluated without input being updated. It is killing me that I can't figure this out, and I'd appreciate any help possible!
Example code:
library(shiny) # shiny_1.0.0
library(DT) # DT_0.2
testModuleUI <- function(id) {
ns = NS(id)
tagList(
br(),
sidebarPanel(width = 12, id = "inputBar",
fluidRow(
column(width = 2, checkboxInput(ns("buttonA"), label = "Button A", value = F)),
column(width = 2, uiOutput(ns("getButtonB")))
),
dataTableOutput(outputId = ns("tableOutput"))
)
)
}
testModule <- function(input, output, session, showB = F ){
ns = session$ns
output$getButtonB <- renderUI({
if( showB ){
print("call checkboxInput")
checkboxInput(ns("buttonB"), label = "Button B", value = F)
}else{
NULL
}
})
getTable <- reactive({
print("inside getTable")
out = c()
if( input$buttonA ) {
out = paste0(out, "A")
}
if( input$buttonB ){
out = paste0(out, "B")
}
data.frame(var = out)
})
output$tableOutput <- renderDataTable({
print("call getTable")
datatable( getTable() )
})
}
server <- function(input, output, session) {
callModule( module = testModule, id = "test1", showB = T )
session$onSessionEnded( stopApp )
}
ui <- pageWithSidebar(
headerPanel( title = "Test app" ),
sidebarPanel(
width = 3,
selectInput(inputId = "whatever", label = "This button doesn't matter", choices = c("A", "B"))
),
mainPanel(
tabsetPanel(
tabPanel("Tab 1", testModuleUI("test1"))
)
)
)
shinyApp( ui = ui, server = server, options = list(launch.browser = T)
)
Thank you!!

Related

How to solve encoding issues in a shiny app

Any tips to solve encoding problem. I am not able to generate the up (↑) and down (↓) arrows in the code below. When running, the following warning message appears:
Warning messages:
1: unable to translate 'Maximize <U+2191>' to native encoding
2: unable to translate 'Minimize <U+2193>' to native encoding
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(
width = 6,
selectInput("maxmin", label = h5("Maximize or Minimize"),
choices = list("Maximize \u2191" = 1, "Minimize \u2193" = 2), selected = "")
)
)),
mainPanel(
))
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
You can use HTML code for the arrows and proceed like this:
library(shiny)
choicesNames <- list("Minimize", "Maximize")
choicesHTML <- list("Minimize ↓", "Maximize ↑")
choices <- setNames(choicesNames, choicesHTML)
ui <- fluidPage(
selectizeInput("select", label = "Select", choices = NULL),
textOutput("txt")
)
server <- function(input, output, session) {
updateSelectizeInput(
session, "select",
choices = choices,
options = list(render = I("
{
item: function(item, escape) { return '<div>' + item.label + '</div>'; },
option: function(item, escape) { return '<div>' + item.label + '</div>'; }
}
"))
)
output$txt <- renderText({
paste("You chose", input$select)
})
}
shinyApp(ui, server)
Another option is to use my package shinySelect and fontawesome icons for the arrows.
library(shiny)
library(shinySelect)
library(bslib)
library(fontawesome)
choices <- HTMLchoices(
labels = list(
tags$span("Minimize", fa_i("arrow-alt-circle-down")),
tags$span("Maximize", fa_i("arrow-alt-circle-up"))
),
values = list("minimize", "maximize")
)
styles <- list(
borderBottom = "5px solid orange",
color = list(selected = "lime", otherwise = "pink"),
backgroundColor = list(selected = "cyan", otherwise = "seashell")
)
ui <- fluidPage(
theme = bs_theme(version = 4),
titlePanel("shinySelect example"),
selectControlInput(
"inputid",
label = tags$h1("Make a choice", style = "color: red;"),
optionsStyles = styles,
choices = choices,
selected = "minimize",
multiple = FALSE,
animated = TRUE
),
br(),
verbatimTextOutput("textOutput")
)
server <- function(input, output, session) {
output$textOutput <- renderPrint({
sprintf("You selected: %s", input$inputid)
})
}
shinyApp(ui, server)
This is an alternate solution. Solutions provided by #Stephane Laurent are great. To translate unicode points to UTF-8, you can use chr_unserialise_unicode() from rlang package. Try this
library(shiny)
library(rlang)
ll <- chr_unserialise_unicode("<U+2193>")
uu <- chr_unserialise_unicode("<U+2191>")
choicesNames <- list(1,2)
choiceValues <- list(sprintf("Minimize %s",ll),sprintf("Maximize %s",uu))
choices <- setNames(choicesNames, choiceValues)
ui <- fluidPage(
selectInput("maxmin", label = h5("Maximize or Minimize"), choices = NULL),
textOutput("mytxt")
)
server <- function(input, output, session) {
updateSelectInput(session, "maxmin", choices = choices )
output$mytxt <- renderText({
paste("You chose", input$maxmin)
})
}
shinyApp(ui = ui, server = server)

Best practices for returning a server-side generated value from a Shiny module?

Consider the following example application:
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
)
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
div(
numericInput(ns("new_option_input"), label = "Add a new option:"),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
#does not work as intended
updateSelectInput(session = session, inputId = "selection", selected = input$new_option_input)
})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
}
# Run the application
shinyApp(ui = ui, server = server)
Basically, the module should do two things:
Allow user to select a pre-existing option --> return that value from module
Allow user to create their own, new option --> return that value from module
I have #1 working, but am struggling on #2. Specifically, where I have the "does not work" comment. How can I achieve this functionality? What are/is the best practice(s) for returning server-side created values from a Shiny module? This is an example app; the real one involves reading the selectInput options from a database, as well as saving the newly created options in the database. Appreciate any help on this! A lot of SO answers regarding Shiny modules have the older callModule(...) syntax, which makes researching this topic a bit more confusing.
You just need to provide the default value in numericInput. Perhaps you are looking for this.
library(shiny)
library(shinyWidgets)
module_UI <- function(id){
ns <- NS(id)
tagList(
div(
uiOutput(
outputId = NS(id, "selection")
),
shinyWidgets::dropdown(
uiOutput(outputId = NS(id, "new_option")),
style = "unite",
label = "New",
color = "primary",
animate = animateOptions(
enter = animations$fading_entrances$fadeInLeftBig,
exit = animations$fading_exits$fadeOutRightBig
),
up = F,
width = "600px",
inline = T
),
DTOutput(ns("t1"))
)
)
}
module_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
return_values <- reactiveValues(selection=NULL,myiris = iris)
output$selection <- renderUI({
selectInput(inputId = ns("selection"), label = "Select:", choices = 1:5)
})
output$new_option <- renderUI({
tagList(
numericInput(ns("new_option_input"), label = "Add a new option:",10, min = 1, max = 100),
shinyWidgets::actionBttn(
inputId = ns("submit_new_option"),
label = "Submit",
icon = icon("paper-plane"))
)
})
observeEvent(input$submit_new_option, {
return_values$myiris <- iris[1:input$new_option_input,]
#does work as intended
updateSelectInput(session = session, inputId = "selection", choices= c(1:input$new_option_input), selected = input$new_option_input)
})
output$t1 <- renderDT({return_values$myiris})
observe({
return_values$selection <- input$selection
})
return(return_values)
})
}
# Define UI for application that draws a histogram
ui <- fluidPage(
title = "Test App",
module_UI("test"),
verbatimTextOutput(outputId = "selection_chosen"),
DTOutput("t2")
)
# Define server logic required to draw a histogram
server <- function(input, output) {
picker <- module_server("test")
output$selection_chosen <- renderText({
picker$selection
})
output$t2 <- renderDT({picker$myiris[,c(3:5)]})
}
# Run the application
shinyApp(ui = ui, server = server)

Facing issues to access shiny module dynamic input value

I am facing a issue to access my shiny module's dynamic input value from slider in the main shiny server function.
In the following code from SelectInput when metric2 is selected, I should be able to see a slider with a specific range and a default. That works perfectly. But the value from the slider is expected to be shown as TextOutput in the main shiny server function, which is failing.
main shiny file:
library(shiny)
source("modules/showLowHighSliders.R")
ui <- fluidPage(
fluidRow(
column(
3,
selectizeInput(
inputId = "metricID",
selected = NULL,
multiple = TRUE,
label = "Select a metric",
choices = list(
Type1 = c("metric1", "metric2", "metric3"),
Type2 = c("metric4","metric5")
),
options = list('plugins' = list('remove_button'))
)
),
column(2,
uiOutput(outputId = "lowerThresholdText"),
showLowHighSlidersUI("sliders-metric2")
)
)
)
server <- function(input, output){
ret <- callModule(module = showLowHighSliders,
id = "sliders-metric2",
metrics_selected=reactive(input$metricID))
output$lowerThresholdText <- renderText({
if(!is.null(input$metricID )){
if(input$metricID == 'metric2'){
paste("Lower Value: ", ret() )
}
}
})
}
shinyApp(ui, server)
Shiny module: showLowHighSliders.R
showLowHighSlidersUI <- function(id) {
ns <- NS(id)
fluidPage(
fluidRow(
column(12,
tagList(
# uiOutput(ns("lowerThresholdText")),
uiOutput(ns("lowerThresholdSlider"))
)
)
)
)
}
# Function for module server logic
showLowHighSliders <- function(input, output, session, metrics_selected) {
reactive({input$mySlider})
output$lowerThresholdSlider <- renderUI({
#print(metrics_selected())
if(!is.null(metrics_selected() ) ){
if('metric2' %in% metrics_selected() ){
sliderInput(
inputId = "mySlider",
label = "",
min = 0,
max = 200,
value = 20
)
}
}
})
# output$lowerThresholdText <- renderText({
# #print(metrics_selected)
# if(!is.null(metrics_selected() )){
# if('SMA' %in% metrics_selected()){
# paste("Lower SMA: ", input$mySlider )
# }
# }
#
# })
}
I was also unable to access the dynamic input slider value within the module itself shown in the commented part.
Any help is appreciated.
Try this
# Function for module server logic
showLowHighSliders <- function(input, output, session, metrics_selected) {
# reactive({input$mySlider})
ns <- session$ns
output$lowerThresholdSlider <- renderUI({
#print(metrics_selected())
if(!is.null(metrics_selected() ) ){
if('metric2' %in% metrics_selected() ){
sliderInput(
inputId = ns("mySlider"),
label = "",
min = 0,
max = 200,
value = 20
)
}
}
})
output$lowerThresholdText <- renderText({
#print(metrics_selected)
if(!is.null(metrics_selected() )){
#if('SMA' %in% metrics_selected()){
paste("Lower SMA: ", session$input$mySlider )
#}
}
})
}

Conditional Panel does not work after being modularized

I have a weird issue with conditionalPanel in shiny dashboard.
I modularized my chart UI components as I need to call it multiple times.
The conditional Panel seems to work fine if I call it only once. However, if I attempted to call more than once, it stopped working.
Below is the reproducible code:
library(shiny)
library(shinyWidgets)
library(shinydashboard)
library(shinydashboardPlus)
library(highcharter)
library(lubridate)
chartUI <- function(id) {
ns <- NS(id)
tagList(
verbatimTextOutput(ns("group")),
selectInput(ns("freq"),"Select frequency:",
choices = list("Yearly" = "Y","Half yearly" = "H","Quarterly" = "Q",
"Monthly"="M"), selected = "Yearly", multiple = FALSE),
dateInput(ns("dates"), "Select start date:",format = "yyyy-mm-dd", startview = "month", value = dmy("1/1/2014")),
selectInput(ns("link"),"Select link ratio:",choices = list("All" = "all", "Standard" = "std"),selected = "all"),
conditionalPanel("input.link == 'std'", ns=ns, sliderInput(ns("std.month"),"No of months:",min=1,max=119,value=60))
)
}
ui <- shinyUI(
ui = dashboardPagePlus(skin = "red",
header = dashboardHeaderPlus(
title = "TITLE",
titleWidth = 700
),
dashboardSidebar(),
body = dashboardBody(
# boxPlus(
# width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
# sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui1"),
# highchartOutput("")
# ),
boxPlus(
width = NULL,title = "CHART",closable = TRUE,enable_sidebar = TRUE,
sidebar_width = 15,sidebar_start_open = FALSE,sidebar_content = chartUI("chartui2"),
highchartOutput("")
)
),
title = "DashboardPage"
)
)
server <- shinyServer(function(input, output) {
})
shinyApp(ui, server)
If I only call chartui2, conditional panel works fine. But if I call both chartui1 and chartui2, both of them no longer work.
A minimal example with uiOutput / renderUI would be:
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(selectInput(ns("show"), "show or not", choices = c("hide", "show")),
uiOutput(ns("dyn")))
}
dyn_server <- function(input, output, session) {
output$dyn <- renderUI({
ns <- session$ns
if (input$show == "show") {
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
}
})
}
ui <- basicPage(dyn_ui("test"))
server <- function(input, output, session) {
callModule(module = dyn_server, id = "test")
}
runApp(list(ui = ui, server = server))
Edit:
In fact, a minimal example works well with conditionalPanel too (see below). So something else about your app is causing a conflict. Not sure what it is, but I would start adding components one by one and see when these minimal examples start misbehaving.
library(shiny)
dyn_ui <- function(id) {
ns <- NS(id)
tagList(
selectInput(ns("show"), "show or not", choices = c("hide", "show")),
conditionalPanel(
ns = ns,
condition = "input.show == 'show'",
sliderInput(
inputId = ns("std_month"),
"No of months:",
min = 1,
max = 119,
value = 60
)
)
}
ui <- basicPage(
dyn_ui("test"),
dyn_ui("test2")
)
server <- function(input, output, session) {
}
runApp(list(ui = ui, server = server))

How to refresh a shiny datatable with a button that runs a function

I have looked everywhere and cant seem to find help with what must be a common issue.
I have a datatable in a shiny app. I load data into it when it first appears. It consists of one column of text
I want the user be able to press a button that takes the data in the datatable and performs an action on it and then presents a datatable with the result of that function. The function (not shown) basically splits the single column up into several columns.
I cant seem to figure out how to run a function from a button that refreshes and shows the new datatable.
This is what I have so far:
server.R
library(shiny)
library(EndoMineR)
RV <- reactiveValues(data = PathDataFrameFinalColon)
server <- function(input, output) {
output$mytable = DT::renderDT({
RV$data
})
output2$mytable = DT::renderDT({
RV$data<-myCustomFunction(RV$data)
})
}
ui.R
library(shiny)
basicPage(
fluidPage(
DT::dataTableOutput("mytable")
))
basically how do I allow a button on the page to run a specific function that then updates the datatable?
You can use observeEvent() and ignoreInit = TRUE so that the initial dataframe is rendered without the function being applied.
server <- function(input, output) {
RV <- reactiveValues(data = PathDataFrameFinalColon)
output$mytable = DT::renderDT({
RV$data
})
observeEvent(input$my_button,{
RV$data<-myCustomFunction(RV$data)
},ignoreInit = TRUE)
}
ui <- basicPage(
fluidPage(
DT::dataTableOutput("mytable"),
actionButton("my_button",label = "Run Function")
))
I hope this helps you. Have fun;
library(shiny)
library(shinydashboard)
dat = data.frame(id = c("d","a","c","b"), a = c(1,2,3,4), b = c(6,7,8,9))
header <- dashboardHeader(
)
sidebar <- dashboardSidebar(
tags$head(tags$style(HTML('.content-wrapper { height: 1500px !important;}'))),
sidebarMenu (
menuItem("A", tabName = "d1"),
menuItem("B", tabName = "d2"),
menuItem("C", tabName = "d3")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "d1",
box(title = "AAA",
actionButton("refreshTab1_id", "Refresh Tab 1"),
actionButton("sortTable1_id", "Sort Table 1"),
DT::dataTableOutput("table_for_tab_1", width = "100%"))
),
tabItem(tabName = "d2",
box(title = "BBB",
actionButton("refreshTab2_id", "Refresh Tab 2"),
actionButton("sortTable2_id", "Sort Table 2"),
DT::dataTableOutput("table_for_tab_2", width = "100%"))
),
tabItem(tabName = "d3",
box(title = "CCC",
actionButton("refreshTab3_id", "Refresh Tab 3"),
actionButton("sortTable3_id", "Sort Table 3"),
DT::dataTableOutput("table_for_tab_3", width = "100%"))
)
)
)
# UI
ui <- dashboardPage(header, sidebar, body)
# Server
server <- function(input, output, session) {
observe({
if (input$sortTable1_id || input$sortTable2_id || input$sortTable3_id) {
dat_1 = dat %>% dplyr::arrange(id)
} else {
dat_1 = dat
}
output$table_for_tab_1 <- output$table_for_tab_2 <- output$table_for_tab_3 <- DT::renderDataTable({
DT::datatable(dat_1,
filter = 'bottom',
selection = "single",
colnames = c("Id", "A", "B"),
options = list(pageLength = 10,
autoWidth = TRUE#,
# columnDefs = list(list(targets = 9,
# visible = FALSE))
)
)
})
})
observe({
if (input$refreshTab1_id || input$refreshTab2_id || input$refreshTab3_id) {
session$reload()
}
})
}
# Shiny dashboard
shiny::shinyApp(ui, server)

Resources