Hi @jcheng
A reproducible example is provide using a 3 files app (global/ui/server). The steps to reproduce the odd behavior of observerEvent are the following:
- open the app (launch.browser = TRUE is recommended)
- on the main page, upload a csv file (anything with headers and numeric variable would do)
- [you can ignore the Transform data portion of the app for now]
- in the menu of the left column, go to the Plot entry
- select a X and a Y variable
- a plot should appear and a Download panel should also appear.
- click on the Download button
You should observe 2 downloads (if your browser is setup to ask you where to save your downloads, 2 download window should open).
I apologize for the length of the code and the heavy use of modules. However, this example code represents only a fraction of the actual code (I kept the minimal amount of code to reproduce the effect). Because the overall code structure remains intact, some elements of design may appear superfluous... I hope you can ignore this for now.
As far as I can tell, the problem of repeated firing of the observeEvent triggered by the Download button is linked to "Transform data" panel code (even if no action is taken in this panel).
For instance, if I replace "return(c(userDataInfo, modDataInfo))" by "return(c(userDataInfo))" in the dataTab function (which bypasses the effect of the Transform data panel code), the download button behaves just fine.
If you think it is necessary, we can further discuss the intent and merit of the code used implemented in this panel (again, this was heavily gutted compared to the original).
### GLOBAL.R
# Load code
library(shiny)
library(shinydashboard)
library(ggplot2)
scatterPlot <- function(pdata, input){
if (is.null(pdata()) | (!is.null(pdata()) && nrow(pdata())==0) |
length(input$x) == 0 | length(input$y) == 0 |
(length(input$x) >0 && input$x == '') |
(length(input$y) >0 && input$y == '')){
return(NULL)
} else {
data <- pdata()
ggplot(data) + aes_string(x = input$x, y = input$y) + geom_point()
}
}
###
### File upload module
###
fileUpload <- function(input, output, session){
data <- reactive({
if (is.null(input$datafile) |
(length(input$datafile) > 0 && input$datafile == '')){
list(name = NA,
data = NA)
} else {
# Read data
data <- try({
read.table(input$datafile$datapath,
header = TRUE,
sep = ',',
as.is = TRUE,
stringsAsFactors = TRUE
)},
silent = TRUE
)
list(
name = input$datafile$name,
data = data
)
}
})
return(data)
}
fileUploadUI <- function(id, n = 1, width = 4) {
# Create a namespace function using the provided id
ns <- NS(id)
box(
fileInput(inputId = ns('datafile'),
label = 'Select a data file to upload',
multiple = FALSE,
accept = c('text/csv', '.csv')
),
title = ifelse(is.null(n), 'Dataset', sprintf('Dataset %d', n)),
collapsible = FALSE,
width = width,
status = 'primary',
solidHeader = TRUE
)
}
###
### Data module
###
dataTab <- function(input, output, session){
ns <- session$ns
# Initialize dataInfo object and reactiveValue objects for transformation fields
dataInfo <- modDataInfo <- NULL
stSourceData <- reactiveValues()
##############################################################################
# Upload
##############################################################################
# Loading UI
output$dataLoadUI1 <- renderUI({
fileUploadUI(ns('datafile1'), n = 1)
})
dataDf1 <- callModule(fileUpload, 'datafile1')
userDataInfo <- c(dataDf1)
##############################################################################
# transform
##############################################################################
# Re-initialize reactiveValues objects for data transform
observeEvent(
c(input[['datafile1-datafile']]),
{
stSourceData <<- reactiveValues()
}
)
stAllDataNames <- reactive({
sapply(userDataInfo, function(x) x()$name)
})
stDataNames <- reactive({
stDataNames <- sapply(userDataInfo, function(x) x()$name)
stDataNames[!sapply(userDataInfo, function(x) is.na(x()[2]))]
})
output$stDataTransformUI <- renderUI({
if (length(stDataNames())==0){
box(
h5('This functionality is only available when at least 1 dataset is loaded'),
title = 'Transform data',
collapsible = FALSE,
width = 8,
status = 'primary',
solidHeader = TRUE)
} else {
box(
fluidRow(
column(4,
selectInput(inputId = ns('stModDataNameIn'),
label = 'Select modified dataset',
choices = sprintf('Modified dataset %d', 1:10)
),
selectInput(inputId = ns('stSourceDataIn'),
label = 'Select source dataset',
choices = stDataNames()
)
)
),
fluidRow(
column(12,
actionButton(inputId = ns('applyTransformBtn'),
label = 'Save',
icon = icon('save')
)
)
),
title = 'Transform data',
collapsible = FALSE,
width = 8,
status = 'primary',
solidHeader = TRUE
)
}
})
outputOptions(output, 'stDataTransformUI', suspendWhenHidden = FALSE)
# Store data in modDataInfo which is a list of 10 reactive
observeEvent(input$applyTransformBtn,
{
stSourceData[[input$stModDataNameIn]] <- input$stSourceDataIn
}
)
modDataInfo <- c(
lapply(sprintf('Modified dataset %d', 1:10), function(x){
reactive({
input$applyTransformBtn
isolate({
dataNames <- sapply(userDataInfo, function(x) x()$name)
if (length(stSourceData[[x]])>0 && stSourceData[[x]] %in% dataNames){
list(
name = x,
data = userDataInfo[[which(dataNames == stSourceData[[x]])]]()$data
)
} else {
list(
name = NA,
data = NA)
}
})
})
})
)
##############################################################################
# Set up UI
##############################################################################
output$dataTabBox <- renderUI({
tabBox(
tabPanel('Data',
fluidRow(
uiOutput(ns('dataLoadUI1')),
uiOutput(ns('stDataTransformUI'))
)
),
width = 12
)
})
return(c(userDataInfo, modDataInfo))
}
dataTabUI <- function(id) {
# Create a namespace function using the provided id
ns <- NS(id)
fluidRow(
uiOutput(ns('dataTabBox'))
)
}
###
### Download module
###
downloadPlot <- function(input, output, session, plots){
ns <- session$ns
output$downloadBoxUI <- renderUI({
box(title = 'Download',
fluidRow(
column(12,
actionButton(inputId = ns('dlAcBtn'),
label = 'Download'
),
downloadButton(outputId = ns('dlPlot'),
label = 'Download',
style = 'visibility: hidden;')
)
),
collapsible = FALSE,
width = 3,
status = 'primary',
solidHeader = TRUE
)
})
observeEvent(
input$dlAcBtn,
{
# Avoid execution if data sets are updated and dlActBtn was >0
if (input$dlAcBtn == 0){
return(NULL)
} else {
shinyjs::runjs(
sprintf('document.getElementById(\'%s\').click();',
ns('dlPlot')
)
)
}
},
ignoreInit = TRUE
)
output$dlPlot <- downloadHandler(
filename = function() {
'junk.png'
},
content = function(file) {
png(file)
print(plots[[1]]())
dev.off()
}
)
}
downloadPlotUI <- function(id){
# Create a namespace function using the provided id
ns <- NS(id)
uiOutput(ns('downloadBoxUI'))
}
###
### Plot module
###
scatterTab <- function (input, output, session, dataInfo){
ns <- session$ns
# Selector of dataset
allDataNames <- reactive({
req(dataInfo)
sapply(dataInfo, function(x) x()$name)
})
dataNames <- reactive({
req(dataInfo)
dataNames <- sapply(dataInfo, function(x) x()$name)
dataNames[!sapply(dataInfo, function(x) is.na(x()[2]))]
})
output$dataSelectUI <- renderUI({
dataLists <- dataNames()[!is.na(dataNames())]
names(dataLists) <- dataLists
selectInput(inputId = ns('dataSelectUI'),
label = 'Select a dataset',
choices = dataLists,
width='100%')
})
selectedDataIndex <- reactive({
req(input$dataSelectUI)
which(allDataNames()==input$dataSelectUI)
})
# Reactive selected data
pdata <- reactive({
req(selectedDataIndex)
dataInfo[[selectedDataIndex()]]()$data
})
# data UI
output$dataUI <- renderUI({
if (length(dataNames()[!is.na(dataNames())]) == 0){
NULL
} else {
box(title = 'Data',
uiOutput(ns('dataSelectUI')),
collapsible = FALSE,
width = 3,
status = 'primary',
solidHeader = TRUE
)
}
})
# The settings UI
output$baseOptionsUI <- renderUI({
req(pdata())
data <- pdata()
box(
fluidRow(
column(4,
selectInput(inputId = ns('x'),
label = 'X axis variable',
choices = c('',sort(names(data)))
)
),
column(4,
selectInput(inputId = ns('y'),
label = 'Y axis variable',
choices = c('',sort(names(data)))
)
)
),
title = 'Basic settings',
collapsible = FALSE,
width = 6,
status = 'info',
solidHeader = TRUE
)
})
# The plot
plot <- reactive({
scatterPlot(
pdata = pdata,
input = input)
})
output$plot <- renderPlot({
if (is.null(plot()))
return(NULL)
plot()
})
# The scatter plot UI
output$plotUI <- renderUI({
if (length(dataNames()[!is.na(dataNames())]) == 0){
box(title = 'Plot',
h5('This functionality is only available when at least 1 dataset is loaded.'),
collapsible = FALSE,
width = 12,
status = 'primary',
solidHeader = TRUE
)
} else {
box(title = 'Plot',
plotOutput(ns('plot')),
collapsible = FALSE,
width = 9,
status = 'primary',
solidHeader = TRUE
)
}
})
output$dlPlotUI <- renderUI({
if (any(class(try(plot(), silent=TRUE)) == 'try-error')){
NULL
} else {
if (is.null(plot()) | length(dataNames()[!is.na(dataNames())]) == 0){
NULL
} else {
downloadPlotUI(ns('downloadPlotUI'))
}
}
})
callModule(downloadPlot, 'downloadPlotUI', list(plot))
}
scatterTabUI <- function(id){
ns <- NS(id)
fluidRow(
uiOutput(ns('plotUI')),
uiOutput(ns('dataUI')),
uiOutput(ns('dlPlotUI')),
uiOutput(ns('baseOptionsUI'))
)
}
naUI <- function(nodata, title){
if (nodata){
box(title = title,
h5('This functionality is only available when at least 1 dataset is loaded.'),
collapsible = FALSE,
width = 12,
status = 'primary',
solidHeader = TRUE
)
} else {
NULL
}
}
###UI.R
ui <- fluidPage(
shinyjs::useShinyjs(),
dashboardPage(
header=dashboardHeader(
title='myApp'
),
sidebar=dashboardSidebar(
sidebarMenu(
menuItem('Data', tabName = 'dataTab', icon = icon('table'), selected = TRUE),
menuItem('Plot', tabName = 'scatTab', icon = icon('area-chart')
)
)
),
body=dashboardBody(
tabItems(
tabItem(tabName = 'blank',
fluidRow()
),
# Data
tabItem(tabName = 'dataTab',
dataTabUI('getData')
),
# Plots
tabItem(tabName = 'scatTab',
conditionalPanel(
condition = "output.nodata",
uiOutput('naScatterUI')
),
conditionalPanel(
condition = "!output.nodata",
scatterTabUI('scatPlot')
)
)
)
),
title='myApp',
skin='blue'
),
offset = 0,
style = 'padding:0px;'
)
### SERVER.R
server <- function(input, output, session) {
## Data tab
dataInfo <- list(
reactive({
list(
name = 'mtcars',
data = mtcars
)
}),
reactive({
list(
name = 'iris',
data = iris
)
}),
reactive({
list(
name = 'ToothGrowth',
data = ToothGrowth
)
})
)
# Ignore the following line to completely bypass the code of the Data tab
dataInfo <- callModule(dataTab, 'getData')
## Main plot tab
nodata <- reactive({all(sapply(dataInfo, function(x) {is.na(x()[2])}))})
output$nodata <- reactive({nodata()})
outputOptions(output, 'nodata', suspendWhenHidden = FALSE)
observe(
{
if (!nodata()){
# Scatterplot tab
callModule(scatterTab, 'scatPlot', dataInfo)
}
}
)
# Display UI when modules are not available yet
output$naScatterUI <- renderUI({ naUI(nodata(), 'Plot') })
}