How to stop download in downloadHandler


#1

Hi,

I have this app with multiple download buttons for which I need to implement some security checks. The goal is to prevent the download if certain checks fail when the user clicks on the download button, and to display a modal dialog displaying some info about the check failure.

In the following example, I am able to display a modal dialog when the download button is clicked, but it seems that I have to include a dummy write.csv call; otherwise the app crashes.

I would great appreciate any suggestion.


ui <- fluidPage(
  downloadLink("downloadData", "Download")
)

server <- function(input, output) {
  # Our dataset
  data <- mtcars
  
  output$downloadData <- downloadHandler(
    filename = function() {
      paste("data-", Sys.Date(), ".csv", sep="")
    },
    content = function(file) {
      if (TRUE){
        showModal(
          modalDialog(
            title = 'Error',
            p('Hello world!'),
            footer = tagList(
              actionButton(inputId = 'inOK', label = 'OK')
            )
          )
        )
        write.csv(NULL, file)
      } else {
        write.csv(data, file)
      }
    }
  )
}

shinyApp(ui, server)


#2

This was a bit tricky but I think I have a solution using some CSS and JS.

The CSS styling hides the visibility of the actual downloadButton but it remains functional and accessible to client-side JS code.

Then I used an actionButton styled the same way as a download button to initiate an observeEvent block of code.

If your checks fail it will show the modal dialog, if they pass it will run some JS code using the shinyJS package to simulate a 'click' of the hidden download button and then the download handler code will run.

However this isn't a perfect solution in terms of security because the actual download link will be visible in the html page source code.

library(shiny)

ui <- fluidPage(
  shinyjs::useShinyjs(),
  actionButton("init", "Download", icon = icon("download")),
  downloadButton("downloadData", "Download", style = "visibility: hidden;")
)

server <- function(input, output) {
  # Our dataset
  data <- mtcars
  
  observeEvent(input$init, {
    if (TRUE) {
      showModal(
        modalDialog(
          title = 'Error',
          p('Hello world!')
        )
      )
    } else {
      shinyjs::runjs("document.getElementById('downloadData').click();")
    }
  })
  
  output$downloadData <- downloadHandler(
    filename = function() {
      paste("data-", Sys.Date(), ".csv", sep="")
    },
    content = function(file) {
      write.csv(data, file)
    }
  )
}

shinyApp(ui, server)

#3

Thanks @paul

I will test your suggestion.

However this isn't a perfect solution in terms of security because the
actual download link will be visible in the html page source code.

I guess I could have the checks in the observeEvent and downHandler, so that dummy content is exported if the hidden download link is "found and exploited."


#4

Hi @paul

First off, your suggested code works just fine as is. So a big thank you for that.

However, I am in a bit of a quandary right now because I have a follow-up problem with the implementation of this code in my real app and because I can not share this app due to BI issues.
The problem is that the expression inside the observeEvent is fired at least twice although the button is clicked only once and the of the event expression (input$init) remains the same. I tried to look at the reactLog but my app is so complex that this ends up being a huge messy ball of connected nodes that can hardly be read.
I have an ugly workaround in place right now which is based on a global variable that counts the number of time the shinyjs::runjs arm of the if statement was executed; if the button counter has a different value from this global variable, I allow shinyjs::runjs to be executed... not the most elegant way, but this works.

observeEvent(input$init, {
    if (TRUE) {
      showModal(
        modalDialog(
          title = 'Error',
          p('Hello world!')
        )
      )
    } else {
      if (input$init != globalVar){ #this requires a global.R, ui.R, and server.R setup I think
        shinyjs::runjs("document.getElementById('downloadData').click();")
        globalVar <<- globalVar + 1
      }
    }
  })

I was wondering if you would have an idea about why an observeEvent could be fired multiple times while the value of the event expression do not change.


#5

Can you provide a reproducible example of this issue? If there is a way to trigger observeEvent twice for a single change I would be flabbergasted!

Thanks!


#6

Hi @jcheng,

I am trying to create a reproducible example. My app is really big and is confidential, so I have to strip it down and it is taking some time.

In the meantime, I can tell you what I observe:

  • clicking on the download button issues multiple downloads in my web browser when my security checkes pass
  • if I insert a browser() call inside the handler expression of observeEvent, the code is stopped multiple times per click on the download button and the value of the event expression (in my case the value of the actionbutton) is the same
  • if I insert a browser() call in the content function of the downloadHandler, the code is stopped multiple times per click of the download button.

I will try to get this reproducible example as fast as I can...


#7

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:

  1. open the app (launch.browser = TRUE is recommended)
  2. on the main page, upload a csv file (anything with headers and numeric variable would do)
  3. [you can ignore the Transform data portion of the app for now]
  4. in the menu of the left column, go to the Plot entry
  5. select a X and a Y variable
  6. a plot should appear and a Download panel should also appear.
  7. 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') })
  
}


#8

The problem is that your callModule(scatterTab, 'scatPlot', dataInfo) is being called multiple times, since you are calling it from inside an observer (that takes a dependency on nodata). Therefore, there are multiple copies of the observers inside scatterTab being created, and thus the shinyjs::runjs you're using to initiate a download (why are you doing that by the way?) is running multiple times.

Just take the callModule(scatterTab, ...) out of the observer and it works fine.


#9

Thanks Joe,

Your reply begs a follow-up question: the intention of putting the callModule inside the observer was to improve the load time of my app by loading the module only when necessary; could you suggest an alternative coding that would load the module only once when nodata is FALSE? I tried a few things based upon isolate calls, but I don't seem to get something functional...


#10

A solution to keep the callModule in an observer but only load the module once:

1- putt a counter variable in the global.R: callModuleCount <- 0
2- define the callModule call as follows:

  observe(
    {
      if (!nodata() & callModuleCount == 0){
        # Scatterplot tab
        callModuleCount <<- 1
        callModule(scatterTab, 'scatPlot', dataInfo)
        
      }
    }
  )

#11

Thanks @paul and @joe for providing solutions on my question.

With that said, a feature request was posted to the Shiny github page to address the inability of downloadHandler to gracefully exit.