I'm trying to learn how to use shiny modules. I started with a simple app that is very similar to the one in the documentation. The app ask you to check a box, then you can upload a csv file, and it will show you a table with the data:
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyjs)
# Header
header <- dashboardHeader()
# Sidebar
sidebar <- dashboardSidebar(
checkboxInput("agree", p("I read ",
a("the very important stuff",
href="http://stackoverflow.com/",
target="_blank")), FALSE),
fileInput(
"chosenfile",
label = h4("File input"),
accept = ".csv"
))
# Body
body <- dashboardBody(
useShinyjs(),
box(
title = "Test",
width = 12,
solidHeader = TRUE,
status = "warning",
dataTableOutput('tbl')
)
)
# ui
ui <- dashboardPage(header, sidebar, body)
# server
server <- function(input, output) {
#Load the chosen dataset
data <- reactive({
dfile <-
input$chosenfile[1, 4] # <- filename with path is the [1,4] cell in obj
if (!is.null(dfile))
readr::read_csv(dfile)
})
output$tbl <- renderDataTable(data(),
options = list(scrollX = TRUE,
pageLength = 10,
searching = FALSE))
observe({
if (input$agree == T) {
# enable the download button
shinyjs::enable("chosenfile")
}
})
observe({
if (input$agree == F) {
# enable the download button
shinyjs::disable("chosenfile")
}
})
}
#run
shinyApp(ui, server)
I want to create a module that has the check the box, upload the file part of the app.
Right now I have this:
# Module
# Module UI function
csvFileInput <- function(id, label = "CSV file") {
# Create a namespace function using the provided id
ns <- NS(id)
tagList(
checkboxInput(ns("agree"), p("I read ",
a("the very important stuff",
href="http://stackoverflow.com/",
target="_blank"))),
fileInput(ns("file"), label)
)
}
# Module server function
csvFile <- function(input, output, session) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
readr::read_csv(userFile()$datapath)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyjs)
# Header
header <- dashboardHeader()
# Sidebar
sidebar <- dashboardSidebar(
csvFileInput("datafile", "CSV file")
)
# Body
body <- dashboardBody(
useShinyjs(),
box(
title = "Test",
width = 12,
solidHeader = TRUE,
status = "warning",
dataTableOutput("table")
)
)
# ui
ui <- dashboardPage(header, sidebar, body)
# server
server <- function(input, output) {
datafile <- callModule(csvFile, "datafile")
output$table <- renderDataTable({
datafile()
})
}
#run
shinyApp(ui, server)
I'm not sure how to implement the the enable/disable part of the module.
I tried this, but the app crashes:
# Module
# Module UI function
csvFileInput <- function(id, label = "CSV file") {
# Create a namespace function using the provided id
ns <- NS(id)
tagList(
checkboxInput(ns("agree"), p("I read ",
a("the very important stuff",
href="http://stackoverflow.com/",
target="_blank"))),
fileInput(ns("file"), label)
)
}
# Module server function
csvFile <- function(input, output, session) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
readr::read_csv(userFile()$datapath)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
diable_button <- function(input, output, session, button, agree){
observe({
if (agree == T) {
# enable the download button
shinyjs::enable(button)
}
})
observe({
if (agree == F) {
# enable the download button
shinyjs::disable(button)
}
})
}
## app.R ##
library(shiny)
library(shinydashboard)
library(shinyjs)
# Header
header <- dashboardHeader()
# Sidebar
sidebar <- dashboardSidebar(
csvFileInput("datafile", "CSV file")
)
# Body
body <- dashboardBody(
useShinyjs(),
box(
title = "Test",
width = 12,
solidHeader = TRUE,
status = "warning",
dataTableOutput("table")
)
)
# ui
ui <- dashboardPage(header, sidebar, body)
# server
server <- function(input, output) {
datafile <- callModule(csvFile, "datafile")
callModule(diable_button, "datafile",
button = input$chosenfile,
agree = input$agree)
output$table <- renderDataTable({
datafile()
})
}
#run
shinyApp(ui, server)
Related
Let's say I have 4 sets of UI/Server modules in 4 different directories ("./X1/Y1/", "./X1/Y2/", "./X2/Y1/", "./X2/Y2/"). I want to load the selected set based on the input in the sidebar.
I tried using source() within dashboardBody(), but I was not successful.
library(shiny)
library(shinydashboard)
# path to modules
in_path <- "C:/a/b/c/"
# ui
ui <- dashboardPage(
dashboardHeader(title = "test"),
dashboardSidebar(
br(),
selectInput('f1', 'Folder 1', choices = c("X1", "X2")),
helpText(""),
selectInput('f2', 'Folder 2', choices = c("Y1", "Y2")),
br(),
actionButton("load", "Load", icon("thumbs-up"), width = "85%")
),
dashboardBody(
# UI module here from, e.g., "C:/a/b/c/X1/Y2/my_UI.R"
)
)
# server
server <- function(input, output, session) {
# server module here from, e.g., "C:/a/b/c/X1/Y2/my_Server.R"
}
shinyApp(ui, server)
As shiny modules are simply functions, I'd source them in the beginning, and use uiOutput to display the differnt modules.
Here's a working example of the general idea (sample module code proudly stolen from the official Shiny documentation):
<mod1.R>
counterButton <- function(id, label = "Counter") {
ns <- NS(id)
tagList(
actionButton(ns("button"), label = label),
verbatimTextOutput(ns("out"))
)
}
counterServer <- function(id) {
moduleServer(
id,
function(input, output, session) {
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
})
output$out <- renderText({
count()
})
count
}
)
}
<mod2.R>
csvFileUI <- function(id, label = "CSV file") {
ns <- NS(id)
tagList(
fileInput(ns("file"), label),
checkboxInput(ns("heading"), "Has heading"),
selectInput(ns("quote"), "Quote", c(
"None" = "",
"Double quote" = "\"",
"Single quote" = "'"
))
)
}
csvFileServer <- function(id, stringsAsFactors = TRUE) {
moduleServer(
id,
## Below is the module function
function(input, output, session) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
read.csv(userFile()$datapath,
header = input$heading,
quote = input$quote,
stringsAsFactors = stringsAsFactors)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
)
}
<app.R>
library(shiny)
source("mod1.R")
source("mod2.R")
my_mods <- list("Counter Button" = list(ui = counterButton,
server = counterServer),
"CSV Uploader" = list(ui = csvFileUI ,
server = csvFileServer))
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("mod_sel",
"Which Module should be loaded?",
names(my_mods))
),
mainPanel(
uiOutput("content"),
verbatimTextOutput("out")
)
)
)
server <- function(input, output) {
uuid <- 1
handler <- reactiveVal()
output$content <- renderUI({
my_mods[[req(input$mod_sel)]]$ui(paste0("mod", uuid))
})
observeEvent(input$mod_sel, {
handler(my_mods[[req(input$mod_sel)]]$server(paste0("mod", uuid)))
uuid <<- uuid + 1
})
output$out <- renderPrint(req(handler())())
}
shinyApp(ui, server)
Some Explanation
You put the module code in mod[12].R and it is rather straight forward.
In your main app, you load both(!) source files and for housekeeping reasons, I put both modules functions (ui and server) in a list, but this is not strictly necessary, but facilitates future extension.
In your UI you have an uiOutput which renders dynamically according to the selected module.
In your server you put the code to dynamically render the UI and call the respective server function.
The uid construct is basically there to force a fresh render, whenever you change the selection. Otherwise, you may see still some old values whenever you come back to a module which you have rendered already.
I have a reactive data frame df1(). A user can add their initials as text inputs such that the text is filled to rows as a new column name when the user clicks the Add button.
Everything works fine but I would like to add one more thing:
Make the download button download show only if the action button bttn1 is pressed. Currently download is shown regardless of pressing bttn1.
I can't understand why the following is not working:
observe({
if (is.null(input$bttn1)) {shinyjs::hide("download")}
else {shinyjs::show("download")}
})
The following is a fully working code:
##### ui
ui <- dashboardPage(
skin = "black",
#### Upper navigation bar
dashboardHeader(
title = "title",
titleWidth = 230
),
#### Side bar
dashboardSidebar(disable = T),
#### Body
dashboardBody(
shinyjs::useShinyjs(),
tabsetPanel(
tabPanel(
### tab1
tabName = "tab1",
h5("Tab 1"),
fluidRow(
reactableOutput("table1"),
textInput("textinput1", "Initials:"),
actionButton("bttn1", "Add", class = "btn-primary"),
reactableOutput("table2"),
uiOutput("ui_download")
) # fluidRow
), # tabPanel
#### tab2
tabPanel(
tabName = "tab2",
h5("Tab 2"),
fluidRow(
) # fluidRow
) # tabPanel
) # tabsetPanel
) # dashboardBody
) # dashboardPage
#### server
server <- function(input, output, session) {
## df1
# reactive
df1 <- reactive({
data.frame(
"id" = c("A", "A", "A", "A"),
"num1" = c(10, 11, 12, 13)
)
})
# renderReactable
output$table1 <- renderReactable({
reactable(df1(), borderless = F, defaultColDef = colDef(align = "center"))
})
## df2
## Text input
rv1 <- reactiveValues()
observe({
if (nrow(df1()) == 0) {shinyjs::hide("bttn1")}
else {shinyjs::show("bttn1")}
})
observe({
if (nrow(df1()) == 0) {shinyjs::hide("textinput1")}
else {shinyjs::show("textinput1")}
})
observeEvent(input$bttn1, {
rv1$values <- df1()
rv1$values$name <- input$textinput1
})
rv1_text <- reactive({
rv1$values
})
output$table2 <- renderReactable({
req(rv1_text())
reactable(rv1_text(), borderless = F, defaultColDef = colDef(align = "center"))
})
## downloadButton
# renderUI
output$ui_download <- renderUI({
# req(rv1_text())
downloadButton("download", "Download")
})
**# Why isn't this working?**
observe({
if (is.null(input$bttn1)) {shinyjs::hide("download")}
else {shinyjs::show("download")}
})
# Download csv
output$download <- downloadHandler(
filename = function() {
paste0('data', '.csv')
},
content = function(file) {
write.csv(rv1_text(), file, row.names = F)
}
)
}
shinyApp(ui, server)
I couldn't run your codes since you did not share the libraries you used in. But If I understand you correctly, conditionalPanel is very suitible for your purpose.
Here is a small shiny app that you can adapt it to your codes:
library(shiny)
ui <- fluidPage(
actionButton("call_download", "Show Download Button"),
conditionalPanel(condition = "input.call_download == 1",
downloadLink('downloadData', 'Download')
)
)
server <- function(input, output) {
output$downloadData <- downloadHandler(
filename = function() {
paste('data-', Sys.Date(), '.csv', sep='')
},
content = function(con) {
write.csv(mtcars, con)
} )
}
shinyApp(ui, server)
I need the selected checkbox labels to fill in the "[,c("checkbox1","checkbox2")]" field (where both "checkbox1" and "checkbox2" are written). Thank you.
This is my code.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(readxl)
library(tidyverse)
library(readxl)
library(stringr)
ui <- fluidPage(
br(),
fileInput("archive", "Upload file", accept = c(
".xlsx")),
# Itens Selection
checkboxGroupInput("additem", "Select Items", choices = NULL)
)
box(
width = 2000,
verbatimTextOutput("calfa")
)
server <- function(input, output, session) {
# Upload Data Sheet
csv <- reactive({
req(input$archive)
inFile <- input$archive
df <- read_xlsx(inFile$datapath)
return(df)
})
#reactive value that will hold the name of the file
reactive_my_path <- reactive({
# Test if file is selected
req(input$archive)
return(sub(".xlsx$", "", basename(input$archive$name)))
})
observe({
input$archive
# update the choices in input$additem
updateCheckboxGroupButtons(session,
"additem",
paste('Column names in:', reactive_my_path()),
choices = names(csv()))
})
# Alpha
output$calfa <-
renderPrint({
int<-csv()[,c("checkbox1","checkbox2")]
int <- na.omit(int)
psych::alpha(int, check.keys = TRUE)
})
}
# App
shinyApp(ui, server)
You can use input$additem to include all the checkbox that are selected. Also I have included another condition to run the psych::alpha code only when there is more than one column.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(readxl)
library(tidyverse)
library(readxl)
library(stringr)
ui <- fluidPage(
br(),
fileInput("archive", "Upload file", accept = c(
".xlsx")),
# Itens Selection
checkboxGroupInput("additem", "Select Items", choices = NULL),
box(
width = 2000,
verbatimTextOutput("calfa")
)
)
server <- function(input, output, session) {
# Upload Data Sheet
csv <- reactive({
req(input$archive)
inFile <- input$archive
df <- read_xlsx(inFile$datapath)
return(df)
})
#reactive value that will hold the name of the file
reactive_my_path <- reactive({
# Test if file is selected
req(input$archive)
return(sub(".xlsx$", "", basename(input$archive$name)))
})
observe({
input$archive
# update the choices in input$additem
updateCheckboxGroupButtons(session,
"additem",
paste('Column names in:', reactive_my_path()),
choices = names(csv()))
})
# Alpha
output$calfa <-
renderPrint({
req(length(input$additem) > 1)
int<-csv()[,input$additem]
int <- na.omit(int)
psych::alpha(int, check.keys = TRUE)
})
}
# App
shinyApp(ui, server)
What I do:
I have a shiny App that returns every column of my csv as a verbatim ouput. I attached my current code (UI.R and Server.R) and the csv-File below.
My Question: I need to write such an app for many different csv-files that all have a variing number of columns. How do I do this automatically without having to write
output$myColumn01 = renderPrint({
as.character(D$Names)
})
and
h1("Names"),
verbatimTextOutput("myColumn01"),
for every column manually?
-
Here is my csv ("myCSV.csv"):
Names;Pages;Scores;Numbers
George;T;3;5
Jim;I;4;23
Jack;T;6;12
Anna;R;4;3
Here is my server.R-File:
library(shiny)
library(dplyr)
library(shinydashboard)
server <- shinyServer(function(input, output, session) {
D = read.csv(file = "myCSV.csv", sep = ";")
output$myColumn01 = renderPrint({
as.character(D$Names)
})
output$myColumn02 = renderPrint({
as.character(D$Pages)
})
output$myColumn03 = renderPrint({
as.character(D$Scores)
})
output$myColumn04 = renderPrint({
as.character(D$Numbers)
})
})
Here is my ui.R-File:
library(shiny)
library(dplyr)
library(shinydashboard)
ui <- shinyUI(dashboardPage(
dashboardHeader(title = "Sessions"),
dashboardSidebar(
width = 350,
collapsed = TRUE,
""
),
dashboardBody(
h1("Names"),
verbatimTextOutput("myColumn01"),
h1("Pages"),
verbatimTextOutput("myColumn02"),
h1("Scores"),
verbatimTextOutput("myColumn03"),
h1("Numbers"),
verbatimTextOutput("myColumn04")
)
))
Is it what you expect ?
library(shiny)
library(dplyr)
library(shinydashboard)
server <- shinyServer(function(input, output, session) {
D = read.csv(file = "myCSV.csv", sep = ";")
lapply(1:ncol(D), function(i){
output[[sprintf("myColumn%02d",i)]] <-
renderPrint({
as.character(D[[colnames(D)[i]]])
})
})
output$ui <- renderUI({
lapply(1:ncol(D), function(i){
tagList(
h1(colnames(D)[i]),
verbatimTextOutput(sprintf("myColumn%02d",i))
)
})
})
})
ui <- shinyUI(dashboardPage(
dashboardHeader(title = "Sessions"),
dashboardSidebar(
width = 350,
collapsed = TRUE,
""
),
dashboardBody(
uiOutput("ui")
)
))
shinyApp(ui=ui, server=server)
I have created a sample app below to illustrate the issue I am having. I have an application in Shiny that is using many layers of modules. I am very familiar with using modules and returning reactive values from the modules themselves. However when I need to use lapply to create multiple calls of modules (in this case slider_menu_item_shiny function to create multiple sliders), each which return the reactive value that is set by the user in sliders, I am not sure how to dynamically capture all of the output reactive variables into one reactive vector.
Right now I have 2 sliders hard coded in and this simple app works. However I want to be able to type in an arbitrary value in the first input, have the app create that amount of slider modules using the lapply statement (for the callModule(slider_menu_item_shiny) call too) and then have slider_value_vector contain a vector of that length with all of the slider values.
I feel like I am missing a fundamental trick to making this work. I would really appreciate the learning experience and all of the help.
ui.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
# define header
header <- dashboardHeader(
title = "Test"
)
# define body
body <- dashboardBody(
tabItems(
body_set_shinyUI(id = "body_test_mod", tab_name = "body_test_mod")
)
)
# define sidebar
sidebar <- dashboardSidebar(
sidebarMenu(id = "dashboard_menu",
menuItem("Test Body", tabName = "body_test_mod")
)
)
dashboardPage(skin = "blue",
header,
sidebar,
body
)
server.R code
library(shiny)
library(shinydashboard)
library(DT)
#### MODULE CODE ####
source("modules.R")
#### SERVER CODE ####
function(input, output, session) {
callModule(body_set_shiny, id = "body_test_mod")
}
modules.R code
### body_set_shiny
body_set_shinyUI <- function(id, tab_name) {
ns <- NS(id)
tabItem(tabName = tab_name,
fluidRow(
column(12,
inner_body_test_menu_shinyUI(ns("inner_body_test_mod"))
)
)
)
}
body_set_shiny <- function(input, output, session) {
callModule(inner_body_test_menu_shiny, id = "inner_body_test_mod")
}
### inner_body_test_menu_shiny
inner_body_test_menu_shinyUI <- function(id) {
ns <- NS(id)
fluidRow(
column(12,
box(title = "Test Inner Menu",
width = 12,
fluidRow(
column(12,
wellPanel(
uiOutput(ns("inner_number_menu")),
uiOutput(ns("inner_sliders_menu")),
uiOutput(ns("inner_text_output"))
)
)
)
)
)
)
}
inner_body_test_menu_shiny <- function(input, output, session) {
output$inner_number_menu <- renderUI({
ns <- session$ns
textInput(ns("inner_number_value"), label = "Enter Number of Sliders", value = "2")
})
slider_length <- reactive({
if (is.null(input$inner_number_value))
return()
as.numeric(input$inner_number_value)
})
output$inner_sliders_menu <- renderUI({
if (is.null(slider_length()))
return()
ns <- session$ns
lapply((1:slider_length()), function(m) {
slider_menu_item_shinyUI(ns(paste("slider_menu_item_", m, sep = "")))
})
})
output$inner_text_output <- renderText({
if (is.null(slider_value_vector()))
return()
paste("You have entered", slider_value_vector())
})
slider_value_vector <- reactive({
if (is.null(slider_length()))
return()
c(as.numeric(slider_v1()[[1]]),as.numeric(slider_v2()[[1]]))
})
slider_v1 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 1, sep = ""))
slider_v2 <- callModule(slider_menu_item_shiny, paste("slider_menu_item_", 2, sep = ""))
}
slider_menu_item_shinyUI <- function(id) {
ns <- NS(id)
uiOutput(ns('sider_output_menu'))
}
slider_menu_item_shiny <- function(input, output, session, slider_value = 0, slider_name = "No Name Found") {
output$sider_output_menu <- renderUI({
ns <- session$ns
uiOutput(ns("slider_item_menu"))
})
output$slider_item_menu <- renderUI({
ns <- session$ns
sliderInput(ns("slider_item"), label = "Slider Example", min = -1, max = 1, value = 0.5, step = 0.01)
})
return(reactive(list(input$slider_item)))
}