Cannot use data in shiny after for loop - r

I'm trying to write a shiny app for pseudonymisation. It needs to receive a CSV file, let the user select which columns need to be removed, and download the data. The problem I cannot solve is why the for loop doesn't work as it does in a normal script.
Here is the code.
UI
library(shiny)
fluidPage(
titlePanel("Anonimizador"),
sidebarLayout(
sidebarPanel(
fileInput(
'file_input',
'Escolha a base de dados para anonimização',
accept = c(
'text/csv',
'text/comma-separated-values',
'.csv'
)
),
radioButtons(
"separador",
"Separador: ",
choices = c(";",",",":")
),
radioButtons(
"encoding",
"Encoding: ",
choices = c("UTF-8", "latin1")
)
),
mainPanel(
fluidRow(
dataTableOutput("table_output")
),
hr(),
fluidRow(
column(
6,
checkboxGroupInput(
"colunas",
"Selecione as colunas para anonimizar:",
choices = NULL
)
),
column(
6,
downloadButton(
'downloadData',
'Baixe a base anonimizada'
)
)
)
)
)
)
SERVER
library(shiny)
library(dplyr)
shinyServer(function(session, input, output) {
db <- reactive({
inFile <- input$file_input
if (is.null(inFile)) return(NULL)
db <- read.csv(
inFile$datapath,
header = TRUE,
sep = input$separador,
encoding = input$encoding
)
return(db)
})
output$table_output <- renderDataTable({
db <- db()
db
},
options = list(
scrollX = TRUE,
pageLength = 5
)
)
observe({
updateCheckboxGroupInput(
session,
"colunas",
"Selecione as colunas para anonimizar:",
choices = names(db())
)
})
db_anonimizado <- reactive({
db <- db()
colunas <- names(db[,input$colunas])
db_novo <- db
for (i in 1:length(colunas)) {
unicos <- data.frame(
original = unique(db[,colunas[i]]),
novo = 1:nrow(unique(db[,colunas[i]]))
)
db_novo <- left_join(db_novo, unicos, by = colunas[i])
}
db_novo$unico <- 1:nrow(db_novo)
nomes_novos <- names(db_novo[,(ncol(db_novo)-length(colunas)): ncol(db_novo)])
db_novo$indicador_anonimizado <- do.call(
paste0,
db_novo[,nomes_novos]
)
remove <- c(colunas, nomes_novos)
db_novo <- db_novo[,-which(names(db_novo) %in% remove)]
db_novo
})
output$downloadData <- downloadHandler(
filename = function() {
paste('anonimizada.csv')
},
content = function(file) {
write.csv(
db_anonimizado(),
file
)
}
)
})
If anyone could help me I'd be very grateful

You have several issues in your code.
When you select only one column, you need to handle it slightly differently in the for loop.
nrow(unique(db[,colunas[i]])) gives a NULL for me. Perhaps length() is better here.
You needed a +1 in ncol(db_novo)-length(colunas)+1
Full code
library(shiny)
ui <- fluidPage(
titlePanel("Anonimizador"),
sidebarLayout(
sidebarPanel(
fileInput(
'file_input',
'Escolha a base de dados para anonimização',
accept = c(
'text/csv',
'text/comma-separated-values',
'.csv'
)
),
radioButtons(
"separador",
"Separador: ",
choices = c(",",";",":")
),
radioButtons(
"encoding",
"Encoding: ",
choices = c("UTF-8", "latin1")
)
),
mainPanel(
fluidRow(
dataTableOutput("table_output"), DTOutput("t1")
),
hr(),
fluidRow(
column(
6,
checkboxGroupInput(
"colunas",
"Selecione as colunas para anonimizar:",
choices = NULL
)
),
column(
6,
downloadButton(
'downloadData',
'Baixe a base anonimizada'
)
)
)
)
)
)
library(dplyr)
server <- shinyServer(function(session, input, output) {
db <- reactive({
inFile <- input$file_input
if (is.null(inFile)) return(NULL)
db <- read.csv(
inFile$datapath,
header = TRUE,
sep = input$separador,
encoding = input$encoding
)
return(db)
})
output$table_output <- renderDataTable({
db <- db()
db
},
options = list(
scrollX = TRUE,
pageLength = 5
)
)
observe({
updateCheckboxGroupInput(
session,
"colunas",
"Selecione as colunas para anonimizar:",
choices = names(db())
)
})
db_anonimizado <- reactive({
req(input$colunas,db())
db <- db()
colunas <- names(db[,input$colunas])
db_novo <- db
n <- length(input$colunas)
if (n==1) {
unicos <- data.frame(
original = unique(db[,input$colunas]),
novo1 = 1:length(unique(db[,input$colunas]))
)
names(unicos)[1] <- c(sym(input$colunas))
db_novo <- left_join(db_novo, unicos, by = names(unicos)[1])
lastcol <- ncol(db_novo)
nomes_novos <- c(names(db_novo)[lastcol])
remove <- c(input$colunas, nomes_novos)
db_novo$indicador_anonimizado <- db_novo[,c(nomes_novos)]
}else if (n>1) {
for (i in 1:n) {
unicos <- data.frame(
original = unique(db[,colunas[i]]),
novo2 = 1:length(unique(db[,colunas[i]]))
)
names(unicos)[1] <- c(sym(colunas[i]))
db_novo <- left_join(db_novo, unicos, by = colunas[i])
}
nomes_novos <- names(db_novo[,(ncol(db_novo)-length(colunas)+1): ncol(db_novo)])
remove <- c(colunas, nomes_novos)
db_novo$indicador_anonimizado <- do.call(
paste0,
db_novo[,c(nomes_novos)]
)
}
#print(nomes_novos)
db_novo$unico <- 1:nrow(db_novo)
#nomes_novos <- names(db_novo[,(ncol(db_novo)-length(colunas)): ncol(db_novo)])
# db_novo$indicador_anonimizado <- do.call(
# paste0,
# db_novo[,c(nomes_novos)]
# )
#remove <- c(colunas, nomes_novos)
db_novo <- db_novo[,-which(names(db_novo) %in% remove)]
db_novo
})
output$t1 <- renderDT({
req(db_anonimizado())
db_anonimizado()
})
output$downloadData <- downloadHandler(
filename = function() {
paste('anonimizada.csv')
},
content = function(file) {
write.csv(
db_anonimizado(),
file
)
}
)
})
shinyApp(ui, server)

Related

How to set up actionButton() or actionBttn() to clear all selections in pickerInput()

When I click on the Action Button, I would like to clear everything: both the output and the selections in the picketInput() (input$engine and input$cylinder in the code below). For consistency if I can do it with shinyWidget's actionBttn, that will be great as well.
library(shiny)
library(shinyWidgets)
df <- mtcars
ui <- fluidPage(
sidebarPanel(
pickerInput("engine", "Select engine:", choices = unique(df$vs),
options = list(
`actions-box` = TRUE),
multiple = TRUE
),
pickerInput("cylinder", "Select cylinder:", choices = unique(df$cyl),
options = list(
`actions-box` = TRUE),
multiple = TRUE
),
actionButton("reset", "Clear Selection"),
),
mainPanel(
textOutput("results")
)
)
server <- function(input, output, session) {
data <- reactiveValues()
observeEvent(input$cylinder, {
tmp <- df
tmp1 <- tmp[tmp$vs %in% input$engine, ]
tmp2 <- tmp1[tmp1$cyl %in% input$cylinder, ]
data$tmp2 <- tmp2
})
output$results <- renderText({
if(is.null(data$tmp2)) return()
print(row.names(data$tmp2))
})
observeEvent(input$reset, {
updatePickerInput(session, "engine", NULL)
updatePickerInput(session, "cylinder", NULL)
data$tmp2 <- NULL
})
}
shinyApp(ui = ui, server = server)
You'll have to respect the order of updatePickerInput's parameters or name them. Your above approach would have updated the label.
Please see ?updatePickerInput and check the following:
library(shiny)
library(shinyWidgets)
library(datasets)
DF <- mtcars
ui <- fluidPage(
sidebarPanel(
pickerInput("engine", "Select engine:", choices = unique(DF$vs),
options = list(
`actions-box` = TRUE),
multiple = TRUE
),
pickerInput("cylinder", "Select cylinder:", choices = unique(DF$cyl),
options = list(
`actions-box` = TRUE),
multiple = TRUE
),
actionBttn("reset", "Clear Selection"),
),
mainPanel(
textOutput("results")
)
)
server <- function(input, output, session) {
data <- reactiveValues()
observeEvent(input$cylinder, {
tmp <- DF
tmp1 <- tmp[tmp$vs %in% input$engine, ]
tmp2 <- tmp1[tmp1$cyl %in% input$cylinder, ]
data$tmp2 <- tmp2
})
output$results <- renderText({
req(data$tmp2)
row.names(data$tmp2)
})
observeEvent(input$reset, {
updatePickerInput(session, inputId = "engine", selected = "")
updatePickerInput(session, inputId = "cylinder", selected = "")
data$tmp2 <- NULL
})
}
shinyApp(ui = ui, server = server)

communication for ShinyModules for generating Rmarkdown report

I have a fully functioning shiny, constructed of four different modules, in the first module, we upload the dataset we have, and in the second and third modules, we can plot based on the first module, and in the fourth module, we should be able to generate a report, connected to an rmd. file.
However I would like to render an HTML or PDF report from this, how can it be done? In an ordinary shiny we put the reactive function for the plots in the "report.Rmd" file and it will render the report.
However, it's not that easy with modules, what could be the solution, in order to generate reports based on several modules?
Thanks in advance!
file_upload_UI <- function(id) {
ns <- NS(id)
tabPanel(
"Upload File",
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(ns("file1"), "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)
),
tags$br(),
checkboxInput(ns("header"), "Header", TRUE),
radioButtons(
ns("sep"),
"Separator",
c(
Comma = ",",
Semicolon = ";",
Tab = "\t"
),
","
),
radioButtons(
ns("quote"),
"Quote",
c(
None = "",
"Double Quote" = '"',
"Single Quote" = "'"
),
'"'
)
),
mainPanel(
tableOutput(ns("contents"))
)
)
)
}
file_upload_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
req(input$file1)
inFile <- input$file1
df <- read.csv(inFile$datapath,
header = input$header, sep = input$sep,
quote = input$quote
)
return(df)
})
output$contents <- renderTable({
data()
})
# return data
data
}
)
}
first_page_UI <- function(id) {
ns <- NS(id)
tabPanel(
"First Tab",
titlePanel("My First Plot"),
sidebarPanel(
selectInput(ns("xcol"), "X Variable", ""),
selectInput(ns("ycol"), "Y Variable", "", selected = "")
),
mainPanel(
plotOutput(ns("MyPlot"))
)
)
}
first_page_Server <- function(id, df) {
stopifnot(is.reactive(df))
moduleServer(
id,
function(input, output, session) {
observeEvent(df(), {
updateSelectInput(session,
inputId = "xcol", label = "X Variable",
choices = names(df()), selected = names(df())
)
updateSelectInput(session,
inputId = "ycol", label = "Y Variable",
choices = names(df()), selected = names(df())[2]
)
})
graph_2 <- reactive({
graph_w<- ggplot(df(), aes(.data[[input$xcol]], .data[[input$ycol]])) +
geom_point()
graph_w
})
output$MyPlot <- renderPlot({
graph_2()
})
}
)
}
mod_ggplot_ui <- function(id){
ns <- NS(id)
tabPanel("ggplot Tab",
pageWithSidebar(
headerPanel('My second Plot'),
sidebarPanel(
selectInput(ns('xcol_1'), 'X Variable', ""),
selectInput(ns('ycol_1'), 'Y Variable', "", selected = ""),
checkboxInput(ns("typeplotly"), "Use interactivity", FALSE)
),
mainPanel(
conditionalPanel(
ns = NS(id),
"input.typeplotly == true", plotlyOutput(ns("plotly"))),
conditionalPanel(
ns = NS(id),
"input.typeplotly == false", plotOutput(ns("plot")))
)
)
)
}
mod_ggplot_server <- function(id, df){
stopifnot(is.reactive(df))
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(df(), {
updateSelectInput(session,inputId = "xcol_1",label = "X Variable",choices = names(df()), selected = names(df())
)
updateSelectInput(session,inputId = "ycol_1",label = "y Variable",choices = names(df()), selected = names(df())[2])
}
)
graph <- reactive({
graph_res <- ggplot(df(), aes(.data[[input$xcol_1]], .data[[input$ycol_1]])) +
geom_point()
graph_res
})
output$plot <- renderPlot({
graph()
})
output$plotly <- renderPlotly({
ggplotly(graph())
})
})
}
mod_Report_ui <- function(id){
ns <- NS(id)
tabPanel("Report ",
mainPanel(
width=12,title="Reporting information", solidHeader = TRUE, status = "primary",collapsible = F,
# # Set title of report
fluidRow(
column(4, HTML('Report title')),
column(8,textInput(ns("title"), placeholder='Report title',label=NULL))
),
fluidRow(
column(4, HTML('author')),
column(8,textInput(ns("author"), placeholder='Modeler name',label=NULL))
),
# Start report rendering
fluidRow(
hr(),
column(6,radioButtons(ns('format'), 'Document format', c('PDF', 'HTML', 'Word'),
inline = TRUE)),
column(6, downloadButton(ns("report"), "Generate report",width='100%'))
)
)
)
}
mod_Report_server <- function(id){
moduleServer( id, function(input, output, session){
ns <- session$ns
output$report <- downloadHandler(
filename = function() {
paste('My_report', Sys.Date(), sep = '.', switch(
input$format, PDF = 'pdf', HTML = 'html', Word = 'docx'
))
},
content = function(file) {
src <- normalizePath('report.Rmd')
withProgress(message = 'Report generating in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:10) {
incProgress(1/10)
Sys.sleep(0.40)
}
})
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'report.Rmd', overwrite = TRUE)
library(rmarkdown)
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
}
)
})
}
library(shiny)
library(ggplot2)
library(plotly)
library(datasets)
ui <- shinyUI(fluidPage(
titlePanel("Column Plot"),
tabsetPanel(
file_upload_UI("upload_file"),
first_page_UI("first_page"),
mod_ggplot_ui("ggplot_1"),
mod_Report_ui("Report_1")
)
))
server <- shinyServer(function(input, output, session) {
upload_data <- file_upload_Server("upload_file")
first_page_Server("first_page", upload_data)
mod_ggplot_server("ggplot_1",upload_data)
mod_Report_server("Report_1")
})
shinyApp(ui, server)
Rmarkdown file
title: "r input$title"
author: "r input$author"
output: pdf_document
knitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
library(knitr)
graph_2()
graph()
I came up with the solution. Now there is communication with all the modules and the rmd. file for rendering the report. Took some good time.
file_upload_UI <- function(id) {
ns <- NS(id)
tabPanel(
"Upload File",
titlePanel("Uploading Files"),
sidebarLayout(
sidebarPanel(
fileInput(ns("file1"), "Choose CSV File",
accept = c(
"text/csv",
"text/comma-separated-values,text/plain",
".csv"
)
),
tags$br(),
checkboxInput(ns("header"), "Header", TRUE),
radioButtons(
ns("sep"),
"Separator",
c(
Comma = ",",
Semicolon = ";",
Tab = "\t"
),
","
),
radioButtons(
ns("quote"),
"Quote",
c(
None = "",
"Double Quote" = '"',
"Single Quote" = "'"
),
'"'
)
),
mainPanel(
tableOutput(ns("contents"))
)
)
)
}
file_upload_Server <- function(id) {
moduleServer(
id,
function(input, output, session) {
data <- reactive({
req(input$file1)
inFile <- input$file1
df <- read.csv(inFile$datapath,
header = input$header, sep = input$sep,
quote = input$quote
)
return(df)
})
output$contents <- renderTable({
data()
})
# return data
data
}
)
}
first_page_UI <- function(id) {
ns <- NS(id)
tabPanel(
"First Tab",
titlePanel("My First Plot"),
sidebarPanel(
selectInput(ns("xcol"), "X Variable", ""),
selectInput(ns("ycol"), "Y Variable", "", selected = "")
),
mainPanel(
plotOutput(ns("MyPlot"))
)
)
}
first_page_Server <- function(id, df) {
stopifnot(is.reactive(df))
moduleServer(
id,
function(input, output, session) {
observeEvent(df(), {
updateSelectInput(session,
inputId = "xcol", label = "X Variable",
choices = names(df()), selected = names(df())
)
updateSelectInput(session,
inputId = "ycol", label = "Y Variable",
choices = names(df()), selected = names(df())[2]
)
})
graph_2 <- reactive({
graph_w<- ggplot(df(), aes(.data[[input$xcol]], .data[[input$ycol]])) +
geom_point()
graph_w
})
output$MyPlot <- renderPlot({
graph_2()
})
return(graph_2)
}
)
}
mod_ggplot_ui <- function(id){
ns <- NS(id)
tabPanel("ggplot Tab",
pageWithSidebar(
headerPanel('My second Plot'),
sidebarPanel(
selectInput(ns('xcol_1'), 'X Variable', ""),
selectInput(ns('ycol_1'), 'Y Variable', "", selected = ""),
checkboxInput(ns("typeplotly"), "Use interactivity", FALSE)
),
mainPanel(
conditionalPanel(
ns = NS(id),
"input.typeplotly == true", plotlyOutput(ns("plotly"))),
conditionalPanel(
ns = NS(id),
"input.typeplotly == false", plotOutput(ns("plot")))
)
)
)
}
mod_ggplot_server <- function(id, df){
stopifnot(is.reactive(df))
moduleServer( id, function(input, output, session){
ns <- session$ns
observeEvent(df(), {
updateSelectInput(session,inputId = "xcol_1",label = "X Variable",choices = names(df()), selected = names(df())
)
updateSelectInput(session,inputId = "ycol_1",label = "y Variable",choices = names(df()), selected = names(df())[2])
}
)
graph <- reactive({
graph_res <- ggplot(df(), aes(.data[[input$xcol_1]], .data[[input$ycol_1]])) +
geom_point()
graph_res
})
output$plot <- renderPlot({
graph()
})
output$plotly <- renderPlotly({
ggplotly(graph())
})
return(graph)
})
}
mod_Report_ui <- function(id){
ns <- NS(id)
tabPanel("Report ",
mainPanel(
width=12,title="Reporting information", solidHeader = TRUE, status = "primary",collapsible = F,
# # Set title of report
fluidRow(
column(4, HTML('Report title')),
column(8,textInput(ns("title"), placeholder='Report title',label=NULL))
),
fluidRow(
column(4, HTML('author')),
column(8,textInput(ns("author"), placeholder='Modeler name',label=NULL))
),
# Start report rendering
fluidRow(
hr(),
column(6,radioButtons(ns('format'), 'Document format', c('PDF', 'HTML', 'Word'),
inline = TRUE)),
column(6, downloadButton(ns("report"), "Generate report",width='100%'))
)
)
)
}
mod_Report_server <- function(id, graph_2, graph){
stopifnot(is.reactive(graph_2))
stopifnot(is.reactive(graph))
moduleServer( id, function(input, output, session){
ns <- session$ns
output$report <- downloadHandler(
filename = function() {
paste('My_report', Sys.Date(), sep = '.', switch(
input$format, PDF = 'pdf', HTML = 'html', Word = 'docx'
))
},
content = function(file) {
src <- normalizePath('report.Rmd')
withProgress(message = 'Report generating in progress',
detail = 'This may take a while...', value = 0, {
for (i in 1:10) {
incProgress(1/10)
Sys.sleep(0.40)
}
})
# Set up parameters to pass to Rmd document
params_for_rmd = list(plot_1=graph_2(),
plot_2=graph(),
set_title=input$title,
set_author=input$author)
owd <- setwd(tempdir())
on.exit(setwd(owd))
file.copy(src, 'report.Rmd', overwrite = TRUE)
library(rmarkdown)
out <- render('report.Rmd', switch(
input$format,
PDF = pdf_document(), HTML = html_document(), Word = word_document()
))
file.rename(out, file)
}
)
})
}
library(shiny)
library(ggplot2)
library(plotly)
library(datasets)
ui <- shinyUI(fluidPage(
titlePanel("Column Plot"),
tabsetPanel(
file_upload_UI("upload_file"),
first_page_UI("first_page"),
mod_ggplot_ui("ggplot_1"),
mod_Report_ui("Report_1")
)
))
server <- shinyServer(function(input, output, session) {
upload_data <- file_upload_Server("upload_file")
gplot_1 <- first_page_Server("first_page", upload_data)
gplot_2 <- mod_ggplot_server("ggplot_1",upload_data)
mod_Report_server("Report_1",graph_2 =gplot_1, graph = gplot_2)
})
shinyApp(ui, server)
the rmd. file
---
output: pdf_document
params:
plot_1: NA
plot_2: NA
set_title:
set_author:
title: "`r input$title`"
author: "`r input$author`"
---
```{r setup, include=FALSE}
knitr::opts_chunk$set(echo = TRUE)
library(ggplot2)
library(shiny)
library(rmarkdown)
library(knitr)
my first plot
graph_2()
params$plot_1
my second plot
graph()
params$plot_2

R Shiny - Automatically adding filters with the names of the columns and select values of each column in the data

I would like to add/remove filters based on column names, i.e., if I select 2 column names, those column names should show numericRangeInput or seletizeInput or any other based on the class. Can it be done with conditionalPanel
Here is what I am trying
library(shiny)
nodes = read.csv("data/nodes.csv", header=T, as.is=T)
ui <- shinyUI(
fluidPage(
actionButton("addNode", "Add Node filter", icon=icon("plus", class=NULL, lib="font-awesome")),
uiOutput("filterPage1")
)
)
server <- function(input, output){
i <- 0
observeEvent(input$addNode, {
i <<- i + 1
output[[paste("filterPage",i,sep="")]] = renderUI({
t4 = class(nodes[,names(nodes)[i]])
print(t4)
list(
fluidPage(
fluidRow(
conditionalPanel(
condition = "t4=='character'",
column(6, selectInput(paste("filteringFactor",i,sep=""), paste0(names(nodes4)[i],':'),
choices=unique(nodes[,names(nodes)[i]]), selected=NULL,
width="100%")),
column(6, actionButton(paste("removeFactor",i,sep=""), "",
icon=icon("times", class = NULL, lib = "font-awesome"),
onclick = paste0("Shiny.onInputChange('remove', ", i, ")"))),
condition = "t4=='numeric'",
column(6, sliderInput(paste("filteringFactor",i,sep=""), paste0(names(nodes4)[i],':'),
choices=unique(nodes4[,names(nodes4)[i]]), selected=NULL,
width="100%")),
column(6, actionButton(paste("removeFactor",i,sep=""), "",
icon=icon("times", class = NULL, lib = "font-awesome"),
onclick = paste0("Shiny.onInputChange('remove', ", i, ")")))
)
)
),
uiOutput(paste("filterPage",i + 1,sep=""))
)
})
})
observeEvent(input$remove, {
i <- input$remove
output[[paste("filterPage",i,sep="")]] <- renderUI({uiOutput(paste("filterPage",i + 1,sep=""))})
})
}
shinyApp(ui, server)
I made an example based on the link I shared to elaborate on my comments (yours isn't reproducible):
library(shiny)
library(shinyWidgets)
library(tools)
library(datasets)
d <- data(package = "datasets")
dataset_is <- sapply(gsub(" .*$", "", d$results[,"Item"]), function(x){is(get(x))[1]})
DFs <- names(dataset_is[dataset_is == "data.frame"])
filterParams <- function(vars){
setNames(lapply(vars, function(x){
list(inputId = x, title = paste0(tools::toTitleCase(x), ":"), placeholder = "...")
}), vars)
}
ui <- fluidPage(
fluidRow(
column(
width = 10, offset = 1,
selectInput("dataset", label = "Select dataset", choices = DFs),
tags$h3("Filter data with selectize group"),
uiOutput("panelProxy"),
DT::dataTableOutput(outputId = "table")
)
)
)
server <- function(input, output, session) {
selected_dataset <- reactive({
DF <- get(input$dataset)
setNames(DF, gsub("\\.", "_", names(DF))) # avoid dots in inputId's (JS special character)
})
vars_r <- reactive({
input$vars
})
res_mod <- callModule(
module = selectizeGroupServer,
id = "my-filters",
data = selected_dataset,
vars = vars_r
)
output$table <- DT::renderDataTable({
req(res_mod())
res_mod()
})
output$panelProxy <- renderUI({
available_vars <- names(selected_dataset())
panel(
checkboxGroupInput(
inputId = "vars",
label = "Variables to use:",
choices = available_vars,
selected = available_vars,
inline = TRUE
),
selectizeGroupUI(
id = "my-filters",
params = filterParams(available_vars)
),
status = "primary"
)
})
}
shinyApp(ui, server)

R shiny observeEvent() cannot isolate the reactivity when input$files parameters changes

I met a problem abount R shiny observeEvent(). I have to upload three csv table files to separately show at different tabpanels. And I set a selectInput to set if to show header of table. At last I give a actionButton(ui)-observeEvent(server) to decide whether to run the showing process. But I find the selectInput just skip the observeEvent(), dynamicly change the show.That is observeEvent is invalidted.I dont'know why.I want selectInput can be under control of actionButton(). I doubt if observeEvent() is a good option to execute the job. Hope somebody can help me! Thanks in advance. Here is my demo code
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
observe({
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
The problem is that you wrap output$mytabs in an observe. I'm not sure why this influences also the content of the output$Group1 etc. you generate in the renderUI call and overrules the observeEvent. Anyway, you don't need the observe, outputs are automatically updated when a dependency changes:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- reactive({
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observeEvent(input$update, {
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)
Edit
I think this solution is more what you want. Maybe one can optimise the last observe statement to a better coding pattern:
# get 3 test uploaded files
data(mtcars)
test1 <- mtcars[,c(1:3)]
test2 <- mtcars[,c(5:8)]
test3 <- mtcars[c(1:3),]
write.csv(test1,file = "test1.csv")
write.csv(test2,file = "test2.csv")
write.csv(test3,file = "test3.csv")
# shiny part
library(shiny)
ui <- fluidPage(
# useShinyjs(),
sidebarLayout(
sidebarPanel(
fileInput(
inputId = "files",
label = "Choose CSV File",
multiple = TRUE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")
),
tags$hr(),
selectInput("type", "Choose Data:", choices = c('Noheader'=TRUE,'Header'=FALSE)),
tags$hr(),
actionButton("update", "show",class = "btn btn-primary btn-lg",icon = icon("refresh"), width = "120px"),
),
mainPanel(
uiOutput("mytabs"),
textOutput("text_null", container = h4)
)
)
)
server <- function(input, output, session){
values <- reactiveValues(file_data=NULL)
filedata <- eventReactive(input$update, {
req(input$files)
upload = list()
for(nr in 1:length(input$files[, 1])){
raw_name <- sub(".csv$", "",input$files[[nr, 'name']])
upload[[raw_name]] <- read.csv(file = input$files[[nr, 'datapath']],header = as.logical(input$type))
}
return((upload))
})
output$mytabs = renderUI({
values$file_data <- filedata()
nTabs <- length(filedata())
tabNames <- names(values$file_data)
myTabs = lapply(1: nTabs, function(i) {
tabPanel( tabNames[i],
tags$div(class = "group-output",
tags$br(),
tableOutput(paste0("Group",i))#))
)
)
})
do.call(tabsetPanel, myTabs)
})
observe({
values$file_data <- filedata()
nn_Tabs <- length(filedata())
progress <<- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = "Begin to process data", value = 0)
for (i in 1: nn_Tabs){
local({
my_n <- i
TableName <- paste0("Group",my_n)
output[[TableName]] <- renderTable({ values$file_data[[my_n]] })
print(values$file_data[[my_n]])
progress$inc(1/nn_Tabs, detail = ", Please wait...")
})
}
progress$set(message = "Finished!", value = 1)
})
}
shinyApp(ui, server)

Upload a csv file with actionbutton and display a corrplot

I tried to make a web application with R::shiny but I met a problem with a piece of code. Indeed, I would like to upload a csv file and display a correlogram.
I tried to set up the correlogram with the actionbutton() followed by the updateSelectizeInput()
However an error has been occured :
Error: Unsupported index type: NULL
Anybody have a solution ? thanks
NB - I don't want to use the fileInput widget to upload the csv file ! Only by the actionbutton !
library(shiny)
library(readr)
library(corrplot)
library(DT)
# File used for the example
data(iris)
write.csv(x = iris, file = "iris.csv")
#UI
ui <- shinyUI(
fluidPage(
navbarPage(
id = "navbar",
tabPanel(
title = "UPLOAD",
br(),
actionButton(inputId = "file", label = "ADD A FILE")
)
)
)
)
#SERVER
server <- function(input, output, session) {
path <- reactiveValues(pth = NULL)
file.choose2 <- function(...) {
pathname <- NULL;
tryCatch({
pathname <- file.choose();
}, error = function(ex) {
})
pathname;
}
observeEvent(input$file,{
path$pth <- file.choose2()
})
observeEvent(input$file, {
newvalue <- "B"
updateNavbarPage(session, "navbar", newvalue)
})
data <- reactive({
df <- readr::read_csv(file = path$pth)
return(df)
})
observeEvent(input$file, {
appendTab(
inputId = "navbar",
tabPanel(
value = "B",
title = "Corr",
sidebarLayout(
sidebarPanel(
selectizeInput(
inputId = "select04",
label = "Select features",
choices = NULL,
multiple = TRUE)
),
mainPanel(
plotOutput(
outputId = "corrplot01", height = "650px")
)
)
)
)
}, once = TRUE)
# I suppose there is a problem with this line
observeEvent(input$select04, {
col <- names(data())
col.num <- which(sapply(data(), class) == "numeric")
col <- col[col.num]
updateSelectizeInput(session = session, inputId = "select04", choices = col)
})
output$corrplot01 <- renderPlot({
df <- data()
df1 <- df[,input$select04]
corr <- cor(x = df1, use = "pairwise.complete.obs")
corrplot(corr = corr,
title = "")
})
}
shinyApp(ui, server)
I changed your ui and server a bit, but I think that might solve your problem.
I deleted the observeEvent(input$file, ...{}) from the server and added the ui part in the Ui directly.
I also added 3 req() calls in the data reactive, in the second observeEvent(input$select04, ...{}) which I changed to a normal observe and in the renderPlot call.
library(shiny)
library(readr)
library(corrplot)
library(DT)
# File used for the example
data(iris)
write.csv(x = iris, file = "iris.csv", row.names = F)
#UI
ui <- shinyUI(
fluidPage(
navbarPage(
id = "navbar",
tabPanel(
title = "UPLOAD",
br(),
actionButton(inputId = "file", label = "ADD A FILE"),
tabPanel(
value = "B",
title = "Corr",
sidebarLayout(
sidebarPanel(
selectizeInput(width = "300px",
inputId = "select04",
label = "Select features",
choices = NULL,
multiple = TRUE)
),
mainPanel(
plotOutput(
outputId = "corrplot01", height = "650px")
)
)
)
)
)
)
)
#SERVER
server <- function(input, output, session) {
path <- reactiveValues(pth = NULL)
file.choose2 <- function(...) {
pathname <- NULL;
tryCatch({
pathname <- file.choose();
}, error = function(ex) {
})
pathname;
}
observeEvent(input$file,{
path$pth <- file.choose2()
})
observeEvent(input$file, {
newvalue <- "B"
updateNavbarPage(session, "navbar", newvalue)
})
data <- reactive({
req(path$pth)
df <- readr::read_csv(file = path$pth)
return(df)
})
# I suppose there is a problem with this line
observe({
req(names(data()))
col <- names(data())
col.num <- which(sapply(data(), class) == "numeric")
col <- col[col.num]
updateSelectizeInput(session = session, inputId = "select04", choices = col)
})
output$corrplot01 <- renderPlot({
req(input$select04)
df <- data()
df1 <- df[,input$select04]
corr <- cor(x = df1, use = "pairwise.complete.obs")
corrplot(corr = corr,
title = "")
})
}
shinyApp(ui, server)

Resources