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 am trying to add functions to the selectizeInput holder in my shinydashboard to use them interactively on my dataframe. Is there a way to display a name for each function (e.g monthly and annual) instead of having the function itself printed out?
ibrary(shiny)
library(shinydashboard)
annual <- function(x){
(x/lag(x, 12) - 1)*100
}
monthly <- function(x){
(x/lag(x) - 1)*100
}
ui <- dashboardPage(
dashboardHeader(title = 'Dashboard'),
dashboardSidebar(sidebarMenu
(menuItem(tabName = 'Panel1', text = 'Panel 1')
)
),
dashboardBody(
tabItems(tabItem(tabName = 'Panel1',
fluidRow(box(selectizeInput('select', 'Select',
choices = c(monthly, annual)),height=80,width=4,
)
),
fluidRow(box(width = 13, height = 655))
)
)
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
You could use a named vector to add labels for the choices:
library(shiny)
library(shinydashboard)
annual <- function(x) {
(x / lag(x, 12) - 1) * 100
}
monthly <- function(x) {
(x / lag(x) - 1) * 100
}
ui <- dashboardPage(
dashboardHeader(title = "Dashboard"),
dashboardSidebar(sidebarMenu
(menuItem(tabName = "Panel1", text = "Panel 1"))),
dashboardBody(
tabItems(tabItem(
tabName = "Panel1",
fluidRow(box(selectizeInput("select", "Select",
choices = c("monthly" = monthly, "annual" = annual)
), height = 80, width = 4, )),
fluidRow(box(width = 13, height = 655))
))
)
)
server <- function(input, output) {
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:6875
The following shiny app works well but has a problem: it displays errors or warnings because of the dynamic filtering.
library(shiny)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
library(data.table)
library(shiny)
library(gapminder
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
shinyApp(ui, server)
First part of the problem:
Errors started displaying once I included a filtering method I found here:
https://stackoverflow.com/a/51153769/12131069
After trying different methods, this is the one that works pretty close to what I am looking for.
However, once the app is loaded, this appears in the console:
Logical subscripts must match the size of the indexed input.
Input has size 392 but subscript datasub2()$country== input$country has size 0.
Second part of the problem:
The app is being developed with the {golem} package, which is really helpful when building scalable and maintainable shiny infrastructure. However, I don't get what I am expecting (and I get the errors). How can I solve that? How can I "modularize" the workaround I found to create interdependent filters?
I have been trying something like:
#' awesome_app_ui UI Function
#'
#' #description A shiny Module.
#'
#' #param id,input,output,session Internal parameters for {shiny}.
#'
#' #noRd
#'
#' #import DT
#' #import plotly
#' #import htmltools
#' #import shinydashboard
#' #importFrom reactable JS
#' #importFrom shiny NS tagList
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
df <- gapminder::gapminder
tabBox(width = 9,title = "Results",d = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",DT::dataTableOutput("awesometable"))
}
#' awesome_app Server Functions
#'
#' #noRd
mod_chiffres_cles_ts_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
# #
datasub <- reactive({
df[df$continent == input$continent,]
})
output$country = renderUI({
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
#
datasub2 <- reactive({
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
datasub2()
})
}
Thanks!
Once you use req() appropriately, your program works fine.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
),
fluidRow(),
hr(),
fluidRow(style = 'background: white;',
div(
box(
title= "Much filters",
style = 'height:420px; background: gainsboro; margin-top: 5vw;',
width=3,
solidHeader = TRUE,
uiOutput("continent"),
uiOutput("country")
),
tabBox(
width = 9,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:420px;',"Awesome results !",
style="zoom: 90%;",
DT::dataTableOutput("awesometable")
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
df <- gapminder::gapminder
output$continent = renderUI({
selectizeInput(inputId = "continent",
label = "Continent :",
choices = unique(df[,"continent"]),
selected = unique(df[,"continent"])[1])
})
datasub <- reactive({
req(input$continent)
df[df$continent == input$continent,]
})
output$country = renderUI({
req(datasub())
selectizeInput(inputId = "country",
label = "Country :",
choices = unique(datasub()[,"country"])
)
})
datasub2 <- reactive({
req(datasub(),input$country)
datasub()[datasub()$country == input$country, ]
})
output$awesometable <- DT::renderDataTable({
req(datasub2())
datasub2()
})
}
shinyApp(ui, server)
You can also use modules as shown below. You may need to adjust where you want to place your selectInputs.
library(shiny)
library(data.table)
library(shiny)
library(gapminder)
moduleServer <- function(id, module) {
callModule(module, id)
}
mod_chiffres_cles_ts_ui <- function(id){
ns <- NS(id)
tagList(
box(
title= "Filter",
style = 'height:420px; background: gainsboro; margin-top: 3vw;',
#width=3,
solidHeader = TRUE,
uiOutput(ns("mycontinent"))
)
)
}
mod_chiffres_cles_ts_server <- function(id,dat,var){
moduleServer( id, function(input, output, session){
ns <- session$ns
df <- isolate(dat())
output$mycontinent = renderUI({
selectizeInput(inputId = ns("continent"),
label = paste(var, ":"),
choices = unique(df[,var]),
selected = unique(df[,var])[1])
})
#print(var)
return(reactive(input$continent))
})
}
mod_chiffres_cles_ds_server <- function(id,dat,var,value){
moduleServer( id, function(input, output, session){
df <- isolate(dat())
datasub <- reactive({
val = as.character(value())
df[df[[as.name(var)]] == val,]
})
#print(var)
return(reactive(as.data.frame(datasub())))
})
}
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
titlePanel(
div(style="line-height: 100%",
align = 'center',
span("Awesome reprex"),
hr()
)
),
sidebarMenu(
menuItem("Home", tabName = "Home", icon = icon("fas fa-home")),
menuItem("Main section", tabName = "Main", icon = icon("far fa-chart-bar"))
)
),
dashboardBody(
tabItems(tabItem(tabName = "Home"),
tabItem(tabName = "Main",
fluidRow(
column(6,mod_chiffres_cles_ts_ui("gap1"),
mod_chiffres_cles_ts_ui("gap2")
),
column(6,style = 'background: white;',
div(
tabBox(
width = 12,
title = "Results",
id = "tabset1",
tabPanel(style = 'overflow-y:scroll;height:560px;',"Awesome results !",
style="zoom: 90%;",
DTOutput("awesometable")
)
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
dfa <- reactive(gapminder)
session$userData$settings <- reactiveValues(df1=NULL,df2=NULL)
rv <- reactiveValues()
var1 <- mod_chiffres_cles_ts_server("gap1",dfa,"continent")
observeEvent(var1(), {
data1 <- mod_chiffres_cles_ds_server("gap1",dfa,"continent", var1 )
session$userData$settings$df1 <- data1()
var21 <- mod_chiffres_cles_ts_server("gap2",data1,"country")
df21 <- mod_chiffres_cles_ds_server("gap2",data1,"country", var21 )
session$userData$settings$df2 <- df21()
print(var21)
})
df22 <- reactive(session$userData$settings$df1)
var22 <- mod_chiffres_cles_ts_server("gap2",df22,"country")
observeEvent(var22(), {
print(var22())
data2 <- mod_chiffres_cles_ds_server("gap2",df22,"country",var22)
session$userData$settings$df2 <- data2()
})
output$awesometable <- renderDT({
datatable(session$userData$settings$df2)
})
}
shinyApp(ui, server)
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)
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!!