I'm trying to modularize a shiny app that has a button to reactively switch between tabPanels using updateTabsetPanel(). This works in the non-modular app, but doesn't when making the reactive is contained in a module. I think it has to do with the panels being outside the scope of the module. Below are minimal examples (the non-modular version that works and the modular version that does not). Is there a way to have the module talk to the tabPanels?
# Non-modular version
library(shiny)
library(shinydashboard)
ui <- fluidPage(
fluidRow(
column(
width = 12,
tabBox(
id = "tabset2",
type = "tabs",
selected = "1",
tabPanel("T1", value = "1",
fluidRow(
box(width = 9, "Some content here"),
box(width = 3,
actionButton("switchbutton", "Click to swtich")
)
)
),
tabPanel("T2", value = "2",
fluidRow(
box(width = 9, "Some different content here")
)
)
)
)
)
)
server <- function(input, output, session) {
observeEvent(input$switchbutton, {
updateTabsetPanel(session = session,
inputId = "tabset2",
selected = "2")
})
}
shinyApp(ui, server)
# Modular version
library(shiny)
library(shinydashboard)
switcherButton <- function(id) {
ns <- NS(id)
fluidRow(
column(
width = 12,
tabBox(
id = "tabset2",
type = "tabs",
selected = "1",
tabPanel("T1", value = "1",
fluidRow(
box(width = 9, "Some content here"),
box(width = 3,
actionButton(ns("switchbutton"), "Click to switch")
)
)
),
tabPanel("T2", value = "2",
fluidRow(
box(width = 9, "Some different content here")
)
)
)
)
)
}
switcher <- function(input, output, session, parent) {
observeEvent(input$switchbutton, {
updateTabsetPanel(session = session,
inputId = "tabset2",
selected = "2")
})
}
ui <- fluidPage(
switcherButton("switcher1")
)
server <- function(input, output, session) {
callModule(switcher, "switcher1")
}
shinyApp(ui, server)
I
You have forgotten to wrap the tabBox id in ns(). Just replace "tabset2" by ns("tabset2")
Related
In my App I would like to have 3 fileInput object per row. How should I modify the code ? currently even if I define the column width It just put one fileInput in each row :
library(shiny)
library(shinythemes)
library(shinydashboard)
library(shinyWidgets)
ui <- fluidPage(
theme = shinytheme("lumen"),
shinyWidgets::useShinydashboard(),
navbarPage("test theme",
tabPanel("tab1",
mainPanel(width = 12,
fluidRow(
box(width = 12,
title = "title", status = "primary", solidHeader = TRUE,
numericInput("num","Number of file input",value = 2),
column(width = 3,
uiOutput("fIn"))
)
)
)
)
)
)
server <- function(input, output, session) {
output$fIn <- renderUI({
ind = as.numeric(input$num)
lapply(1:ind, function(k) {
fileInput(paste0("fIn", k), paste('File:', k), accept=c("xlsx","text"))
})
})
}
shinyApp(ui, server)
Instead of wrapping the uiOutput in column wrap each single fileInput in a column:
library(shinyWidgets)
library(shiny)
library(shinydashboard)
ui <- fluidPage(
shinyWidgets::useShinydashboard(),
navbarPage(
"test theme",
tabPanel(
"tab1",
mainPanel(
width = 12,
fluidRow(
box(
width = 12,
title = "title", status = "primary", solidHeader = TRUE,
numericInput("num", "Number of file input", value = 2),
uiOutput("fIn")
)
)
)
)
)
)
server <- function(input, output, session) {
output$fIn <- renderUI({
ind <- as.numeric(input$num)
lapply(1:ind, function(k) {
column(
4,
fileInput(paste0("fIn", k), paste("File:", k), accept = c("xlsx", "text"))
)
})
})
}
shinyApp(ui, server)
I'm trying to create a introduction with pop-up text boxes using "rintrojs" package.
The thing is that I am using modules with golem in my app, so there is one module per each tab.
The problem i'm getting is that when running the app and clicking the button to display the introduction, the 2 dialog boxes appear at the top left corner of the screen.
I'm having the same issue as reported here: Using the ‘rintrojs’ in Shiny to create e step-by-step introductions on app usage; dialog box appears top left corner for some tabs but not others
The difference is that I'm working with modules and the solution proposed here (https://stackoverflow.com/a/70162738/14615249) doesn't work for me.
Here is the problem:
enter image description here
And here is some reproducible code so it gets easier to understand:
library(shiny)
library(rintrojs)
library(shinyWidgets)
# UI Module 1
mod_module1_ui <- function(id){
ns <- NS(id)
tagList(
rintrojs::introjsUI(),
column(
width = 12,
actionButton(
inputId = ns("bt"),
label = "Display Button"
)
),
div(
sidebarPanel(
style = "height: 100px;",
width = 12,
shiny::column(
width = 3,
rintrojs::introBox(
shiny::numericInput(
inputId = ns("numeric"),
label = "Numeric Input",
value = 45
),
data.step = 1,
data.intro = div(
h5("Description goes here")
)
),
),
shiny::column(
width = 3,
rintrojs::introBox(
shinyWidgets::pickerInput(
inputId = ns("picker"),
label = "Picker Input",
choices = c(1, 2, 3, 4, 5)
),
data.step = 2,
data.intro = div(
h5("Description goes here")
)
),
),
),
),
)
}
# SERVER Module 1
mod_module1_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(input$bt, rintrojs::introjs(session))
})
}
# UI Module 2
mod_module2_ui <- function(id){
ns <- NS(id)
tagList(
rintrojs::introjsUI(),
column(
width = 12,
actionButton(
inputId = ns("bt"),
label = "Display Button"
)
),
div(
sidebarPanel(
style = "height: 100px;",
width = 12,
shiny::column(
width = 3,
rintrojs::introBox(
shiny::numericInput(
inputId = ns("numeric"),
label = "Numeric Input",
value = 45
),
data.step = 1,
data.intro = div(
h5("Description goes here")
)
),
),
shiny::column(
width = 3,
rintrojs::introBox(
shinyWidgets::pickerInput(
inputId = ns("picker"),
label = "Picker Input",
choices = c(1, 2, 3, 4, 5)
),
data.step = 2,
data.intro = div(
h5("Description goes here")
)
),
),
),
),
)
}
# SERVER Module 2
mod_module2_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(input$bt, rintrojs::introjs(session))
})
}
# APP UI
app_ui <- function(request) {
tagList(
shiny::navbarPage(
title = ("Example"),
fluid = TRUE,
# 1 - Tab 1 ----
tabPanel(
title = "tab1",
shinydashboard::dashboardHeader(
title = span(
h1("Title tab 1")
)
),
shinydashboard::dashboardBody(
mod_module1_ui("module1_1")
),
),
# 2 - Tab 2 ----
shiny::tabPanel(
title = "tab2",
shinydashboard::dashboardHeader(
title = h1("Title tab 2")
),
shinydashboard::dashboardBody(
mod_module2_ui("module2_1")
),
),
)
)
}
# APP SERVER
app_server <- function(input, output, session) {
mod_module1_server("module1_1")
mod_module2_server("module2_1")
}
shinyApp(app_ui, app_server)
Is there a way to solve this?
Ps: This is my first ever question here in StackOverFlow, so I'd like to apologize in advance if I'm missing important parts of how to ask the question.
Thank you!
This problem was addressed in this Github issue but I write a summary and a similar solution here.
rintrojs works by adding attributes to the HTML elements you want to highlight. For example, it adds data-step=1 as an attribute of the numeric input. The problem is that if you create multiple tours, there will be several elements with the attribute data-step=1, which means that rintrojs will not be able to know which one is the "true first step". This is why only the page top left corner is highlighted.
One solution (detailed in the issue I referred to) is to create the list of steps in the server of each module. Therefore, each time the server part of the module will be called, it will reset the steps of rintrojs, so that there is only one data-step=1 for example.
Here's your example adapted:
library(shiny)
library(rintrojs)
library(shinyWidgets)
# UI Module 1
mod_module1_ui <- function(id){
ns <- NS(id)
tagList(
rintrojs::introjsUI(),
column(
width = 12,
actionButton(
inputId = ns("bt"),
label = "Display Button"
)
),
div(
sidebarPanel(
style = "height: 100px;",
width = 12,
shiny::column(
width = 3,
shiny::numericInput(
inputId = ns("numeric"),
label = "Numeric Input",
value = 45
)
),
shiny::column(
width = 3,
div(
id = ns("mypicker"),
shinyWidgets::pickerInput(
inputId = ns("picker"),
label = "Picker Input",
choices = c(1, 2, 3, 4, 5)
)
)
),
),
)
)
}
# SERVER Module 1
mod_module1_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
intro <- reactive({
data.frame(
element = paste0("#", session$ns(c("numeric", "mypicker"))),
intro = paste(c("Slider", "Button"), id)
)
})
observeEvent(input$bt, rintrojs::introjs(session, options = list(steps = intro())))
})
}
# UI Module 2
mod_module2_ui <- function(id){
ns <- NS(id)
tagList(
column(
width = 12,
actionButton(
inputId = ns("bt"),
label = "Display Button"
)
),
div(
sidebarPanel(
style = "height: 100px;",
width = 12,
shiny::column(
width = 3,
shiny::numericInput(
inputId = ns("numeric"),
label = "Numeric Input",
value = 45
)
),
shiny::column(
width = 3,
div(
id = ns("mypicker"),
shinyWidgets::pickerInput(
inputId = ns("picker"),
label = "Picker Input",
choices = c(1, 2, 3, 4, 5)
)
)
),
),
),
)
}
# SERVER Module 2
mod_module2_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
intro <- reactive({
data.frame(
element = paste0("#", session$ns(c("numeric", "mypicker"))),
intro = paste(c("Slider", "Button"), id)
)
})
observeEvent(input$bt, rintrojs::introjs(session, options = list(steps = intro())))
})
}
# APP UI
app_ui <- function(request) {
tagList(
shiny::navbarPage(
title = ("Example"),
fluid = TRUE,
# 1 - Tab 1 ----
tabPanel(
title = "tab1",
shinydashboard::dashboardHeader(
title = span(
h1("Title tab 1")
)
),
shinydashboard::dashboardBody(
mod_module1_ui("module1_1")
),
),
# 2 - Tab 2 ----
shiny::tabPanel(
title = "tab2",
shinydashboard::dashboardHeader(
title = h1("Title tab 2")
),
shinydashboard::dashboardBody(
mod_module2_ui("module2_1")
),
),
)
)
}
# APP SERVER
app_server <- function(input, output, session) {
mod_module1_server("module1_1")
mod_module2_server("module2_1")
}
shinyApp(app_ui, app_server)
Note that using "picker" in the dataframe containing the steps doesn't really work (only a very small part of the pickerInput is highlighted). This is why I wrap the pickers in div() and use the id of this div() instead.
When running the app, you will see that Option 1 is already selected, however it is strange because in ui I inserted selected="No option selected". So what am I doing wrong?
My idea is that when running the algorithm, there is no option selected in selectInput.
Executable code below:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(
width = 6,
selectInput("test", label = h5("Choose"),choices = list("Option1 " = "1", "Option2" = "2", selected="No option selected")),
))),
mainPanel(
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
One way is to put an empty string in choices:
library(shiny)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
fluidRow(
column(
width = 6,
selectInput("test",
label = h5("Choose"),
choices = list("", "Option1 " = "1", "Option2" = "2"),
selected=NULL),
))),
mainPanel(
)
)
)
server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
How can I select multiple items in selectInput() when selectize=F?
library(shiny)
library(shinydashboard)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = dashboardBody(
uiOutput("box1")
),
title = "DashboardPage"
),
server = function(input, output) {
output$box1<-renderUI({
box(
selectInput(inputId = "in", label = "Choose", choices = c('Short','A very short sentence.'),
selectize = F,multiple=T, size = 5, width = "150px")
)
})
}
)
What you have is allowing multiple selections.
You may see it more clearly if you add this (even if it's temporary)
Add verbatimTextOutput(outputId = "res") after the uiOutput("box1") (don't forget to add a comma) and add output$res <- renderPrint({input$`in`}) after output$box1 in server
library(shiny)
library(shinydashboard)
shinyApp(
ui = dashboardPage(
header = dashboardHeader(),
sidebar = dashboardSidebar(),
body = dashboardBody(
uiOutput("box1"), # comma added here
verbatimTextOutput(outputId = "res") # this is added
),
title = "DashboardPage"
),
server = function(input, output) {
output$box1 <- renderUI({
box(
selectInput(inputId = "in", label = "Choose", choices = c('Short','A very short sentence.'),
selectize = F,multiple=T, size = 5, width = "150px")
)# ends the box
}) # ends output$box1
output$res <- renderPrint({input$`in`}) # this is added here - since 'in' is a keyword I would suggest a different id...
} # ends server call
) # ends shinyApp
I am trying to build a shiny app where the user can decide how many tabs he wants to be shown. Here's what I have so far:
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
tabsetPanel(
lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
value = h3(glue("Content {i}"))
)
})
)
})
}
shinyApp(ui = ui, server = server)
This does not produce the desired results, as the comparison tabs are not shown properly.
I have already checked out these 2 threads:
R Shiny - add tabPanel to tabsetPanel dynamically (with the use of renderUI)
R Shiny dynamic tab number and input generation
but they don't seem to solve my problem. Yes, they create tabs dynamically with a slider, but they don't allow to fill these with content as far as I can tell.
What works for me is a combination for lapply and do.call
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(glue)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sliderInput(inputId = "slider", label = NULL, min = 1, max = 5, value = 3, step = 1)
),
dashboardBody(
fluidRow(
box(width = 12,
p(
mainPanel(width = 12,
column(6,
uiOutput("reference")
),
column(6,
uiOutput("comparison")
)
)
)
)
)
)
)
server <- function(input, output) {
output$reference <- renderUI({
tabsetPanel(
tabPanel(
"Reference",
h3("Reference Content"))
)
})
output$comparison <- renderUI({
req(input$slider)
myTabs = lapply(1:input$slider, function(i) {
tabPanel(title = glue("Tab {i}"),
h3(glue("Content {i}"))
)
})
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui = ui, server = server)