Reactive Inputs using modules in ShinyDashboard - r

I'm trying to use reactive selectizeInput by first time in shiny modules, but It's not working. I read the documentation of modules and reactive inputs, but I don't know how to work with it together. I made a simplify code to show my doubt. This is the code without modules, It's working well:
library(shiny)
library(shinydashboard)
library(highcharter)
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
ui<-dashboardPage(title= "Dashboard", skin= "green",
dashboardHeader(title="PROYECTO"),
dashboardSidebar(
sidebarMenu(id="sidebarID",
menuItem("OVERVIEW",tabName = "datos"
)
)
),
dashboardBody(
tabItems(tabItem(tabName = "datos",
fluidRow(
column(width = 6,
selectizeInput("select",
"Choose",
c("a"="1",
"b"="2")
)),
box(width=6, column( width=12,
column(width=12,highchartOutput("y"))
),
height = 400))
)
)))
server <- function(input, output,session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
}
shinyApp(ui, server)
Now, I was trying to adapt it into modules. I created a module:
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
yUI<-function(id) {tagList(highchartOutput(NS(id,"y")))
}
yServer<-function(id){
moduleServer(id, function(input, output, session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
})}
And shiny dashboard:
a<- c(1,2,3,4,5)
b<- c(0.5,1,2,6,8)
dt <- seq(as.Date("2018-01-01"), as.Date("2018-01-05"), by = "days")
ts <- xts(a, dt )
names(ts)="a"
ts$b <- xts(b, dt )
yUI<-function(id) {tagList(highchartOutput(NS(id,"y")))
}
yServer<-function(id){
moduleServer(id, function(input, output, session) {
y_react<-reactive(
highchart(type="stock") %>%
hc_add_series(ts[,as.numeric(input$select)],
type = "line",
color="red")
)
output$y <-renderHighchart(y_react())
})}
But It's not working.

The issue is that in the module server you are using input$select which however is created outside of the module. Doing so the server will look for a select in the module namespace. However, as there is no input with ID select in the module namespace you get an error.
To fix that you could pass the input$select to the module server as an argument:
``` r
library(shiny)
library(shinydashboard)
library(highcharter)
library(xts)
yUI <- function(id) {
tagList(
highchartOutput(NS(id, "y"))
)
}
yServer <- function(id, choice) {
moduleServer(id, function(input, output, session) {
y_react <- reactive(
highchart(type = "stock") %>%
hc_add_series(ts[, choice],
type = "line",
color = "red"
)
)
output$y <- renderHighchart(y_react())
})
}
ui <- dashboardPage(
title = "Dashboard", skin = "green",
dashboardHeader(title = "PROYECTO"),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("OVERVIEW", tabName = "datos")
)
),
dashboardBody(
tabItems(tabItem(
tabName = "datos",
fluidRow(
column(
width = 6,
selectizeInput(
"select",
"Choose",
c(
"a" = "1",
"b" = "2"
)
)
),
box(
width = 6, column(
width = 12,
column(width = 12, yUI("y"))
),
height = 400
)
)
))
)
)
server <- function(input, output, session) {
yServer("y", as.numeric(input$select))
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:3301
A second option and probably more in the spirt of what modules are meant for would be to include the selectizeInput in the module. Doing so the input with inputID select becomes part of the module namespace and can be accessed from within the module server using input$select. As you want to place the UI elements in different parts of your dashboard I decided for two module UI "functions" which adds the flexibility to place the UI elements individually:
yUI_plot <- function(id) {
tagList(
highchartOutput(NS(id, "y"))
)
}
yUI_select <- function(id) {
selectizeInput(
NS(id, "select"),
"Choose",
c(
"a" = "1",
"b" = "2"
)
)
}
yServer <- function(id) {
moduleServer(id, function(input, output, session) {
y_react <- reactive(
highchart(type = "stock") %>%
hc_add_series(ts[, as.numeric(input$select)],
type = "line",
color = "red"
)
)
output$y <- renderHighchart(y_react())
})
}
ui <- dashboardPage(
title = "Dashboard", skin = "green",
dashboardHeader(title = "PROYECTO"),
dashboardSidebar(
sidebarMenu(
id = "sidebarID",
menuItem("OVERVIEW", tabName = "datos")
)
),
dashboardBody(
tabItems(tabItem(
tabName = "datos",
fluidRow(
column(
width = 6,
yUI_select("y")
),
box(
width = 6, column(
width = 12,
column(width = 12, yUI_plot("y"))
),
height = 400
)
)
))
)
)
server <- function(input, output, session) {
yServer("y")
}
shinyApp(ui, server)
#>
#> Listening on http://127.0.0.1:7210

Related

Multiple fileInput in one line in shiny app

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)

Embedding functions into selectizeinput in shinydashboard

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

Modularize reactiveUI with interdependent filters in shiny with {golem}

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)

Dynamic Tab creation with content

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)

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

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!!

Resources