Related
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.
Do you know how to have a nested appendTab in R. I want to be able to append the tabs with one for loop and in each tab I append other tabs with another for loop.
Thank you for your answers
library(shiny)
ui <- fluidPage(
column(
3,
box(
title = "Validation studies",
actionButton("add", "add tab"),
width = 12
)
),
column(
9,
box(
title = "Validation studies",
tabsetPanel(id = ns("tabs")),
width = 12
)
)
)
server <- function(input, output, session) {
n <- 0
observeEvent(input$add, {
n <<- n + 1
appendTab(inputId = "tabs",
tab = tabPanel(title = "Test",
box(
tabsetPanel(id = ns(paste0("tabs_", n))),
width = 12
)
),
select = TRUE
)
for(i in 1:3){
print(i)
appendTab(inputId=paste0("tabs_",n),
tabsetPanel(
tabPanel(
"Dynamic",
paste("Content for dynamic tab", i)
)
)
)
}
})
}
shinyApp(ui, server)
But I get
Warning: Error in ns: function "ns" could not found
[No stack trace available]
I'm writing a Shiny app with fluidRows and I want to create a dynamic number of columns in the app. I can make columns appear and disappear correctly, but I don't know how to also make them resize accordingly. The desired outcome is that all columns have width 4 if there are 3 of them and width 6 if there are 2. The number of possible columns is 2, 3, or 4 so I don't need to account for more variability than that.
I know that I can probably do it by passing the entire column set through renderUI. However, that would require me to define the contents of the columns in server.R and I'd rather avoid that.
See below for a minimal code example of my app:
library(shiny)
ui <- fluidPage(
titlePanel("Dynamic Columns"),
sidebarLayout(
sidebarPanel(
selectInput("column_count", "Number of Columns", 2:4, 2),
submitButton("Go")
),
mainPanel(
fluidRow(
column(3, "This is column 1"),
column(3, "This is column 2"),
conditionalPanel(
condition = "input.column_count >= 3",
column(3, "This is column 3")
),
conditionalPanel(
condition = "input.column_count == 4",
column(3, "This is column 4")
)
)
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
One way might be to alter the css classes using javascript. I wrote a short js script that calculates the width using the selected value (i.e., 2, 3, 4) and the maximum bootstrap.js columns (i.e., 12): 12 / value, and then updates the class with the new width: col-sm-*. I explicitly named which columns should be resized by adding the class target-column. (You can use any name you like. Make sure it is updated in the js function.). The event is trigged by the submit button.
Here's your example with the javascript. (I wrapped the app in tagList).
library(shiny)
ui <- tagList(
fluidPage(
titlePanel("Dynamic Columns"),
sidebarLayout(
sidebarPanel(
selectInput("column_count", "Number of Columns", 2:4, 2),
submitButton("Go")
),
mainPanel(
fluidRow(
column(3, "This is column 1", class = "target-column"),
column(3, "This is column 2", class = "target-column"),
conditionalPanel(
condition = "input.column_count >= 3",
column(3, class = "target-column", "This is column 3")
),
conditionalPanel(
condition = "input.column_count == 4",
column(3, class = "target-column", "This is column 4")
)
)
)
),
tags$script(
type = "text/javascript",
"
const btn = document.querySelector('button[type=submit]');
const input = document.getElementById('column_count');
btn.addEventListener('click', function(event) {
// calculate new width
w = 12 / input.options[input.selectedIndex].value;
console.log('new width', w);
// update classes
const columns = document.querySelectorAll('.target-column');
columns.forEach(function(column) {
column.className = 'col-sm-' + w + ' target-column';
});
})
"
)
)
)
server <- function(input, output) {}
shinyApp(ui = ui, server = server)
I'm having some trouble with setting out the layout of my shiny app. After trying a couple of different options the one to work the best for me was the navbarPage. Although, I managed to solve the majority of my problems(with the help of stackoverflow) I'm stuck in one.
Basically, I have a table that has many columns and it ends up always larger than the wellPanel that contains the table.
Below is some code to illustrate the problem:
require(shiny)
require(shinythemes)
side_width <- 5
sidebar_panel <-
sidebarPanel(
width = side_width,
radioButtons("Radio1",
label = h4("Radio label 1"),
choices = list("Europe" = "EU",
"USA" = "US"),
selected = "EU"),
hr()
br()
radioButtons("Radio 2",
label = h4("Radio label 2"),
choices = list("Annual" = 1, "Monthly" = 12),
selected = 1)
)
main_panel <- mainPanel(
width = 12 - side_width,
wellPanel(
h5(helpText("Figure 1: ..."))
),
wellPanel(
h5(helpText("Table 1: ..."))
),
wellPanel(
h5(helpText("Table 2: ..."))
),
wellPanel(
fluidRow(
column(12,
h5(helpText("Table 3: ..."))
)
)
)
)
# user interface
ui <- shiny::navbarPage("testing shiny",
tabPanel("Tab1",
sidebarLayout(
sidebarPanel = sidebar_panel,
mainPanel = main_panel,
position = "left")
),
tabPanel("Tab2",
verbatimTextOutput("summary")
),
tags$style(type="text/css", "body {padding-top: 70px;}"),
theme=shinytheme("cosmo"),
position ="fixed-top"
)
server <- function(input, output) {
}
shinyApp(ui = ui, server = server)
When you run the code you will see the current layout. All would be fine if it wasn't for that massive wide table 3 which half of it is always out of the wellPanel.
My question is is it possible to extend the wellPanel to the left so it occupies the entire width of the layout?
Any pointers are highly appreciated.
Cheers
The fluidRow and column functions don't do anything inside the wellPanel/mainPanel - you want to put this particular wellPanel as its own fluidRow separate from the sidebar layout.
Additionally, if your table is being made in the DT package, you can add scrollX=TRUE to the render options so that it'll add a scroll bar if the table is too big to fit.
require(shiny)
require(shinythemes)
side_width <- 5
# user interface
ui <- navbarPage(
"testing shiny",
tabPanel("Tab1",
sidebarLayout(position = "left",
sidebarPanel(width = side_width,
radioButtons("Radio1",
label = h4("Radio label 1"),
choices = list("Europe" = "EU",
"USA" = "US"),
selected = "EU"),
hr(),
br(),
radioButtons("Radio 2",
label = h4("Radio label 2"),
choices = list("Annual" = 1, "Monthly" = 12),
selected = 1)),
mainPanel(
width = 12 - side_width,
wellPanel(
h5(helpText("Figure 1: ..."))
),
wellPanel(
h5(helpText("Table 1: ..."))
),
wellPanel(
h5(helpText("Table 2: ..."))
)
)
),
fluidRow(
column(12,
wellPanel(
h5(helpText("Table 3: ..."))
)
)
)
),
tabPanel("Tab2",
verbatimTextOutput("summary")),
tags$style(type = "text/css", "body {padding-top: 70px;}"),
theme = shinytheme("cosmo"),
position = "fixed-top"
)
I have a shiny application in which a dataTable is displayed when the user selects Sector A from the radioButtons menu in the sidebar. The problem is that it is displayed twice. I checked it in browser mode too. Why does this happen I display the whole app here since it may be caused by the if logic of the app. renderTable() works fine so I guess there is an issue with DT
#ui.r
library(shiny)
library(shinythemes)
library(DT)
ui <- fluidPage(
theme=shinytheme("slate") ,
# App title ----
titlePanel("Tabsets"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
uiOutput("rad")
),
# Main panel for displaying outputs ----
mainPanel(
uiOutput("tabers"),
DT::dataTableOutput("table")
)
)
)
#server.r
library(shiny)
library(DT)
server = function(input, output) {
output$rad<-renderUI({
radioButtons("radio", label = "",
choices = list("Home"=1,"About" = 2, "Sector A" = 3, "Sector B" = 4,"Sector C" = 5),
selected = 1)
#selected = character(0))
})
output$tabers<-renderUI({
if(is.null(input$radio)) {
tabsetPanel(
id="tabF",
type = "tabs",
tabPanel("Global"),
tabPanel("Performance")
)
}
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
output$table <- renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==4){
tabsetPanel(
id="tabD",
type = "tabs",
tabPanel("Constituents"
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==5){
tabsetPanel(
id="tabE",
type = "tabs",
tabPanel("Constituents"
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==2){
}
# Left last else in here but should not get called as is
else if(input$radio==1){
tabsetPanel(
id="tabA",
type = "tabs",
tabPanel("Global"),
tabPanel("Performance" )
)
}
})
}
It looks like renderTable does the same thing. For some reason, the output of renderDataTable({mtcars}) gets displayed twice, first through uiOutput, second through dataTableOutput() (both are in mainPanel). Commenting the line dataTableOutput("table") fixes the behavior in that it shows the table only once. Interestingly, removing the assignment like so:
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
also renders the table once. So it looks like when inside renderUI, renderDataTable just creates the output without requiring a dataTableOutput in the UI.
This seems to allow (for better or worse) to easily render different tables in different tabs without corresponding output entries in the UI.
else if(input$radio==3){
tabsetPanel(
id="tabC",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
mtcars
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}
else if(input$radio==4){
tabsetPanel(
id="tabD",
type = "tabs",
tabPanel("Constituents",
renderDataTable({
iris
})
),
tabPanel("Clusters" ),
tabPanel("Index")
)
}