How to use built-in data instead of uploaded data - r

I have an app like below. I want to either read-in data from file upload or use the built-in data. I thought I could put an action button and if somebody hit it the input data will mount on and it goes to the next levels. My problem is later in my real app, some widgets such as selectInput have to be updated and I want to be empty until user decided whether to use uploaded data or the built-in one.
library(shiny)
x <- mtcars
ui <- fluidPage(
fileInput(inputId = "uploadcsv", "", accept = '.csv'),
actionButton(inputId = "a", label = "action button"),
selectInput("select",label = h3("Select box"),choices = "",selected = 1)
)
server <- function(input, output, session) {
data <- reactive({
infile <- input$uploadcsv
if (is.null(infile))
return(NULL)
read.csv(infile$datapath, header = TRUE, sep = ",")
})
DataToUse <- NULL
observe(!is.null(input$uploadedcsv),
DataToUse <- data()
)
observeEvent(input$a,
DataToUse <- x
)
observe({
req(DataToUse)
if (max(DataToUse$cyl) %% 4 == 0){
numberofinterval <- max(DataToUse$cyl) %/% 4
} else {
numberofinterval <- (max(DataToUse$cyl) %/% 4)+1
}
NumPeriod <- seq(0, numberofinterval)
updateSelectInput(session, inputId = "select",
choices = NumPeriod,
selected = NumPeriod)
})
}
shinyApp(ui = ui, server = server)

Something like this should do:
library(shiny)
x <- mtcars
ui <- fluidPage(
fileInput(inputId = "uploadcsv", "", accept = '.csv'),
actionButton(inputId = "a", label = "action button"),
selectInput("select",label = h3("Select box"),choices = "",selected = 1)
)
server <- function(input, output, session) {
data <- reactive({
infile <- input$uploadcsv
if (is.null(infile))
return(NULL)
read.csv(infile$datapath, header = TRUE, sep = ",")
})
v <- reactiveValues()
v$DataToUse <- NULL
observeEvent(input$uploadcsv,{
if(!is.null(input$uploadcsv)){
v$DataToUse <- data()
}
})
observeEvent(input$a,v$DataToUse <- x)
observeEvent(v$DataToUse,{
req(v$DataToUse)
if (max(v$DataToUse$cyl) %% 4 == 0){
numberofinterval <- max(v$DataToUse$cyl) %/% 4
} else {
numberofinterval <- (max(v$DataToUse$cyl) %/% 4)+1
}
NumPeriod <- seq(0, numberofinterval)
updateSelectInput(session, inputId = "select",
choices = NumPeriod,
selected = NumPeriod)
})
}
shinyApp(ui = ui, server = server)

Related

why does the missing function not work inside of reactive RShiny?

I have an R shiny app that filters on some variables and returns a table using modules. I'd like to use missing() so that the app will still work even if no value is provided to the module. However, when I use missing() inside reactive() it gives an error: Warning: Error in missing: 'missing' can only be used for arguments. Does anyone know why this might be the case? Is there a way to get around this?
Example app:
df <- data.frame(a = sample(letters,100,T), b = sample(10,100,T))
dfFilter <- function(data, a, b){
if (!missing(a)) {
if(!is.null(a)){
data <- data[data$a %in% a,]
}
}
if (!missing(b)) {
if(!is.null(b)){
data <- data[data$b %in% b,]
}
}
return(data)
}
filterTable <- function(input, output, session, data, aFetcher, bFetcher){
return(reactive(dfFilter(data = data,
a = switch(!missing(aFetcher),
aFetcher(),NULL),
b = switch(!missing(bFetcher),
bFetcher(), NULL))))
}
displayTableUI <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('displayer'))
}
displayTable <- function(input, output, session, data){
output$displayer <- DT::renderDataTable(data())
}
chooserUI <- function(id){
ns <- NS(id)
uiOutput(ns('filter'))
}
chooseA <- function(input, output, session, data){
output$filter <- renderUI({
ns <- session$ns
pickerInput(inputId = ns('filter'),
label = 'Choose A:',
choices = unique(data$a),
options = list(`actions-box` = TRUE),
multiple = TRUE)
})
return(reactive(input$filter))
}
chooseB <- function(input, output, session, data){
output$filter <- renderUI({
ns <- session$ns
pickerInput(inputId = ns('filter'),
label = 'Choose B:',
choices = unique(data$b),
options = list(`actions-box` = TRUE),
multiple = TRUE)
})
return(reactive(input$filter))
}
ui <- fluidPage(
tabPanel('data',
sidebarPanel(
chooserUI('aChooser'),
chooserUI('bChooser')
),
mainPanel(
displayTableUI('table1')
)
)
)
server <- function(input,output){
chosenA <- callModule(chooseA,
id = 'aChooser',
data = df)
chosenB <- callModule(chooseB,
id = 'bChooser',
data = df)
table1 <- callModule(filterTable,
data = df,
id = 'tableFilterer',
aFetcher = chosenA,
bFetcher = chosenB)
callModule(displayTable, id = 'table1', data = table1)
}
shinyApp(ui, server)
Fixed by using exists() instead of !missing():
df <- data.frame(a = sample(letters,100,T), b = sample(10,100,T))
dfFilter <- function(data, a, b){
if (!missing(a)) {
if(!is.null(a)){
data <- data[data$a %in% a,]
}
}
if (!missing(b)) {
if(!is.null(b)){
data <- data[data$b %in% b,]
}
}
return(data)
}
filterTable <- function(input, output, session, data, aFetcher, bFetcher){
return(reactive(dfFilter(data = data,
a = switch(exists(aFetcher),
aFetcher(),NULL),
b = switch(exists(bFetcher),
bFetcher(), NULL))))
}
displayTableUI <- function(id){
ns <- NS(id)
DT::dataTableOutput(ns('displayer'))
}
displayTable <- function(input, output, session, data){
output$displayer <- DT::renderDataTable(data())
}
chooserUI <- function(id){
ns <- NS(id)
uiOutput(ns('filter'))
}
chooseA <- function(input, output, session, data){
output$filter <- renderUI({
ns <- session$ns
pickerInput(inputId = ns('filter'),
label = 'Choose A:',
choices = unique(data$a),
options = list(`actions-box` = TRUE),
multiple = TRUE)
})
return(reactive(input$filter))
}
chooseB <- function(input, output, session, data){
output$filter <- renderUI({
ns <- session$ns
pickerInput(inputId = ns('filter'),
label = 'Choose B:',
choices = unique(data$b),
options = list(`actions-box` = TRUE),
multiple = TRUE)
})
return(reactive(input$filter))
}
ui <- fluidPage(
tabPanel('data',
sidebarPanel(
chooserUI('aChooser'),
chooserUI('bChooser')
),
mainPanel(
displayTableUI('table1')
)
)
)
server <- function(input,output){
chosenA <- callModule(chooseA,
id = 'aChooser',
data = df)
chosenB <- callModule(chooseB,
id = 'bChooser',
data = df)
table1 <- callModule(filterTable,
data = df,
id = 'tableFilterer',
aFetcher = chosenA,
bFetcher = chosenB)
callModule(displayTable, id = 'table1', data = table1)
}
shinyApp(ui, server)

Make a Shiny module reactive when creating the module via a function

I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv

Problem in downloading data using Download Handlers in ShinyApp

My original data of mtcar gets downloaded using Download Handlers in ShinyApp whereas i want the the modified data (using SelectInputs) to be downloaded through Handlers.
I have attached my codes as well, please let me know whats wrong with them. Many thanks:)
library(shiny)
library(tidyr)
library(dplyr)
library(readr)
library(DT)
data_table <- mtcars
# Define UI
ui <- fluidPage(
downloadButton('downLoadFilter',"Download the filtered data"),
selectInput(inputId = "cyl",
label = "cyl:",
choices = c("All",
unique(as.character(data_table$cyl))),
selected = "4",
multiple = TRUE),
selectInput(inputId = "vs",
label = "vs:",
choices = c("All",
unique(as.character(data_table$vs))),
selected = "1",
multiple = TRUE),
DT::dataTableOutput('ex1'))
server <- function(input, output) {
thedata <- reactive({
if(input$cyl != 'All'){
return(data_table[data_table$cyl == input$cyl,])
}
else if(input$vs != 'All'){
return(data_table[data_table$vs == input$vs,])
}
else{
return(data_table)
}
})
output$ex1 <- DT::renderDataTable(DT::datatable(filter = 'top',
escape = FALSE,
options = list(pageLength =
10, scrollX='500px',autoWidth = TRUE),{
thedata() # Call reactive
thedata()
}))
output$downLoadFilter <- downloadHandler(
filename = function() {
paste('Filtered data-', Sys.Date(), '.csv', sep = '')
},
content = function(path){
write_csv(thedata(),path) # Call reactive thedata()
})}
shinyApp(ui = ui, server = server)
You are updating thedata() only inside your renderDataTable. You need to make it a reactive and then use it for being rendered as DataTable and being downloaded.
Change your server to:
# Define server logic
server <- function(input, output) {
thedata <- reactive({
if(input$cyl != 'All'){
return(data_table[data_table$cyl == input$cyl,])
}
else{
return(data_table)
}
})
output$ex1 <- DT::renderDataTable(DT::datatable(filter = 'top',
escape = FALSE,
options = list(pageLength = 10, scrollX='500px',autoWidth = TRUE),{
thedata() # Call reactive thedata()
}))
output$downLoadFilter <- downloadHandler(
filename = function() {
paste('Filtered data-', Sys.Date(), '.csv', sep = '')
},
content = function(path){
write_csv(thedata(),path) # Call reactive thedata()
})}

R Shiny loop logical operator

I have a running example: I am updating a data.table depending on users input via checkboxes. So far Iam filtering the data explicitly, but I would like to do that with the help of a loop using a for loop or a function of the apply-family. Unfortunately I cannot get either to work.
library(shiny)
library(data.table)
library(DT)
tdata <- data.table(fruit = c(rep("Apple",4),rep( "Ban",4)),
bug1 = c(rep(c("+","+", "-","-"),2)),
bug2 = c(rep(c("+","-"),4)),
value = c(rep(c(0.25),4), 0.6,0.4,0,0))
ui <- (fluidPage(tagList(
sidebarLayout(
sidebarPanel(uiOutput("file_input")),
mainPanel(dataTableOutput('fruit_table'))
))))
server <- function(input, output) {
fileData <- reactive(
return(tdata)
)
colname_list <- reactive(
colnames(fileData())
)
output$file_input <- renderUI ({
if(is.null(fileData())){
return()
}else{
tagList(
lapply(1:(length(fileData())-1), function(i){
choice_list = unique(fileData()[,get(colnames(fileData()[,i, with = FALSE]))])
checkboxGroupInput(inputId = colnames(fileData()[,i, with = FALSE]),
label = colnames(fileData()[,i, with = FALSE]),
choices = choice_list,
inline = TRUE,
selected = fileData()[1, i, with = FALSE])
})
)
}
})
# works fine, but usually the number of columns changes so I want to keep it flexible
fruitFilter <- reactive({
fileData()[[paste0(colname_list()[1])]] %in% input[[paste0(colname_list()[1])]] &
fileData()[[paste0(colname_list()[2])]] %in% input[[paste0(colname_list()[2])]] &
fileData()[[paste0(colname_list()[3])]] %in% input[[paste0(colname_list()[3])]]
})
# fruitFilter <- reactive({
# for(i in 1: ((length(fileData()))-1)){
# fileData()[[paste0(colname_list()[i])]] %in% input[[paste0(colname_list()[i])]]
# }
# })
output$fruit_table <- renderDataTable({
datatable(fileData()[fruitFilter(),])
})
}
shinyApp(ui = ui, server = server)
I still consider myself a newby to Shiny. I appreciate any help! Thanks.
In the loop approach, we could initialize a list and then Reduce the output to a single logical vector
fruitFilter <- reactive({
i1 <- head(seq_along(fileData()), -1)
l1 <- vector('list', length(i1))
for(i in i1){
l1[[i]] <- fileData()[[colname_list()[i]]] %in% input[[colname_list()[i]]]
}
Reduce(`&`, l1)
})
With the full code
library(shiny)
library(data.table)
library(DT)
tdata <- data.table(fruit = c(rep("Apple",4),rep( "Ban",4)),
bug1 = c(rep(c("+","+", "-","-"),2)),
bug2 = c(rep(c("+","-"),4)),
value = c(rep(c(0.25),4), 0.6,0.4,0,0))
ui <- (fluidPage(tagList(
sidebarLayout(
sidebarPanel(uiOutput("file_input")),
mainPanel(dataTableOutput('fruit_table'))
))))
server <- function(input, output) {
fileData <- reactive(
return(tdata)
)
colname_list <- reactive(
colnames(fileData())
)
output$file_input <- renderUI ({
if(is.null(fileData())){
return()
}else{
tagList(
lapply(1:(length(fileData())-1), function(i){
choice_list = unique(fileData()[,get(colnames(fileData()[,i, with = FALSE]))])
checkboxGroupInput(inputId = colnames(fileData()[,i, with = FALSE]),
label = colnames(fileData()[,i, with = FALSE]),
choices = choice_list,
inline = TRUE,
selected = fileData()[1, i, with = FALSE])
})
)
}
})
fruitFilter <- reactive({
i1 <- head(seq_along(fileData()), -1)
l1 <- vector('list', length(i1))
for(i in i1){
l1[[i]] <- fileData()[[colname_list()[i]]] %in% input[[colname_list()[i]]]
}
Reduce(`&`, l1)
})
output$fruit_table <- renderDataTable({
datatable(fileData()[fruitFilter()])
})
}
shinyApp(ui = ui, server = server)
--output

How to loop through multiple upload widegets in shiny?

I want to create multiple fileInput function to allow users to upload files. The main reason I am creating multiple upload widgets is because I want to allow users to upload through different path. What I am trying to accomplish here is to loop through all the fileInputs and save all the files into one dataframe but not able to do it in example of my code.
library(shiny)
library(data.table)
library(DT)
n_attachments <- sprintf("file%s",seq(1:2))
ui <- fluidPage(
titlePanel('File download'),
sidebarLayout(
sidebarPanel(
textInput("LOAN_NUMBER", label = "Fannie Mae Loan Number", placeholder = "Please enter loan #")
, textInput("REO_ID", label = "REO Number", placeholder = "Please enter REO #")
, fileInput("file1", "Attachments1", accept = c("text/csv", "text/comma-separated-values,text/plain",".csv", ".pdf", ".doc", ".xlsx"), multiple = TRUE)
, fileInput("file2", "Attachments2", accept = c("text/csv", "text/comma-separated-values,text/plain",".csv", ".pdf", ".doc", ".xlsx"), multiple = TRUE)
, textOutput('text')
),
mainPanel(
DT::dataTableOutput("table"), tags$hr()
)
)
)
server <- function(input, output) {
bin_data <- reactive({
attachement_data <- data.frame(ATTACHMENT = character(), FILENAME = character(), LOAN_NUMBER = character(), REO_ID = character())
for(x in n_attachments)
{
output$text <- renderText({ input$x })
req(input$x)
# binary_data <- paste(readBin(input$file1$datapath, what="raw", n=1e6), collapse="-")
# attachment_info <- data.frame(ATTACHMENT = binary_data, FILENAME = paste0(input$file1$name))
# attachment_info
binary_data=list()
filenames=list()
for(i in 1:length(input$x[,1])){
binary_data[[i]] <- paste(readBin(input$x[[i, 'datapath']], what = "raw", n=1e6), collapse = "-")
filenames[[i]] <- input$x[[i, 'name']]
}
bin_data_frame <- data.frame(ATTACHMENT = as.character(unlist(binary_data)), FILENAME = as.character(unlist(filenames)))
bin_data_frame$LOAN_NUMBER <- input$LOAN_NUMBER
bin_data_frame$REO_ID <- input$REO_ID
attachement_data <- rbind(attachement_data, bin_data_frame)
}
save(attachement_data, file="attachement_data.RData")
attachement_data
})
output$table <- DT::renderDataTable({
bin_data()
})
}
shinyApp(ui = ui, server = server)
ok I think I figured it out, I have to use input[[x]] instead of input$x, and I added couple lines to check how many fileinputs are uploaded.
server <- function(input, output) {
bin_data <- reactive({
attachement_data <- data.frame(ATTACHMENT = character(), FILENAME = character(), LOAN_NUMBER = character(), REO_ID = character())
k <- 0
for(x in n_attachments)
{
if(!is.null(input[[x]]))
{
k = k + 1
}
}
for(x in n_attachments[0:k])
{
if(!is.null(input[[x]]))
{
output$text <- renderText({ input[[x]] })
req(input[[x]])
# binary_data <- paste(readBin(input$file1$datapath, what="raw", n=1e6), collapse="-")
# attachment_info <- data.frame(ATTACHMENT = binary_data, FILENAME = paste0(input$file1$name))
# attachment_info
binary_data=list()
filenames=list()
for(i in 1:length(input[[x]][,1])){
binary_data[[i]] <- paste(readBin(input[[x]][[i, 'datapath']], what = "raw", n=1e6), collapse = "-")
filenames[[i]] <- input[[x]][[i, 'name']]
}
bin_data_frame <- data.frame(ATTACHMENT = as.character(unlist(binary_data)), FILENAME = as.character(unlist(filenames)))
bin_data_frame$LOAN_NUMBER <- input$LOAN_NUMBER
bin_data_frame$REO_ID <- input$REO_ID
attachement_data <- rbind(attachement_data, bin_data_frame)
}
}
save(attachement_data, file="attachement_data.RData")
attachement_data
})
output$table <- DT::renderDataTable({
bin_data()
})
}
shinyApp(ui = ui, server = server)

Resources