Make a download button in shiny app that saves a data.frame in an excel file and downloads the excel file in the user's computer in a shiny app

shiny

#1

I have made an application on R shiny that I share with friends on the same network. I host the application on my remote computer and people connect to it using dedicated ports. I am trying to make a download button that saves a data.frame in an excel file and downloads the excel file in the user’s computer. Currently, I am able to make the download button but it only writes the file to a folder in the remote server. I need help with the downloadhandler essentially. Thank you for your time. Here a csc reproducible example

library(shiny) 
library(e1071)
library(rminer)
library(dplyr)
library(tidyr)
library(ggplot2)
library(ggvis)
library(corrplot)
library(DT)
library(caret)
ui <- navbarPage(title = "HR Analytics         ",

                 tabPanel("Data Import",
                          sidebarLayout(sidebarPanel(
                            fileInput('file1', 'Choose CSV File to upload',
                                      accept=c('text/csv', 
                                               'text/comma-separated-values,text/plain', 
                                               '.csv')),
                            helpText("Note: Please ensure that the the file is in .csv",
                                     "format and contains headers."),
                            tags$hr(),
                            actionButton("do", "Import")
                          ),
                          mainPanel(h2(helpText("Descriptive Statistics")),
                                    verbatimTextOutput('contents'))
                          )
                 ),#tabpanel
                 tabPanel("Predictive Model",
                          sidebarLayout(sidebarPanel(
                            uiOutput("model_select"),
                            actionButton("enter", "Enter")
                          ),
                          mainPanel(h2(helpText("Model Output")),
                                    verbatimTextOutput('modelOutput'))
                          )
                 ),#tabpanel
                 tabPanel("Report",
                          sidebarLayout(sidebarPanel(
                            tags$style(type="text/css",
                                       ".shiny-output-error { visibility: hidden; }",
                                       ".shiny-output-error:before { visibility: hidden; }"
                            ),
                            helpText("Download final list of employess to be retained"),
                            br(),
                            uiOutput("modsel"),
                            helpText("Select Model"),
                            uiOutput("noselect"),
                            helpText("Select number pf employess"),
                            downloadButton('downloadData', 'Download'),
                            helpText("Download final list of employees to be retained")
                          ),

                          mainPanel(h2(helpText("Retained Employees")),
                                    dataTableOutput("reportOutput"))
                          )
                 )#tabpanel


)


library(shiny)

server <- function(input, output) {

  hr = eventReactive(input$do,{
    inFile <- input$file1

    if (is.null(inFile))
      return(NULL)

    hr = read.csv(inFile$datapath, header=T, sep=",")
  })

  output$contents <- renderPrint({
    return(summary(hr()))
  })

  output$model_select<-renderUI({
    selectInput("modelselect","Select the model",choices = c("Tree Learning"="rpart","Logistic Regression"="LogitBoost", "Naive Bayes" = "nb"))
  })

  output$modsel<-renderUI({
    selectInput("modelselect2","Select Algo",choices = c("Logistic Regression","Naives Bayes","Tree Learning"),selected = "Logistic_reg")
  })

  output$noselect<- renderUI({
    sliderInput("noselect", "Number of observations:",
              min = 0, max = 300, value = 20)})


  algo = eventReactive(input$enter,{
    return(input$modelselect)
  })


  output$modelOutput <- renderPrint({
    hr_model <- hr() %>% filter(left==0 | last_evaluation >= 0.70 | time_spend_company >= 4 | number_project > 5)
    hr_model$left <- as.factor(hr_model$left)
    train_control<- trainControl(method="cv", number=5, repeats=3)
    rpartmodel<- train(left~., data=hr_model, trControl=train_control, method=algo())
    # make predictions
    predictions<- predict(rpartmodel,hr_model)
    hr_model_tree<- cbind(hr_model,predictions)
    # summarize results
    confusionMatrix<- confusionMatrix(hr_model_tree$predictions,hr_model_tree$left)
    confusionMatrix
  })

  rt <- reactive(
    if(input$modelselect2== "Logistic Regression"){
      f1<-data()
      hr_model1 <- hr() %>% filter(left==0 |last_evaluation >= 0.70 | time_spend_company >= 4 | number_project > 5)
      hr_model1$left <- as.factor(hr_model1$left)
      train_control<- trainControl(method="cv", number=5, repeats=3)
      # Keep some data to test again the final model
      set.seed(100)
      inTraining <- createDataPartition(hr_model1$left, p = .75, list = FALSE)
      training <- hr_model1[ inTraining,]
      testing  <- hr_model1[-inTraining,]
      # Estimate the drivers of attrition
      logreg = glm(left ~ ., family=binomial(logit), data=training)
      # Make predictions on the out-of-sample data
      probaToLeave=predict(logreg,newdata=testing,type="response")
      # Structure the prediction output in a table
      predattrition = data.frame(probaToLeave)
      # Add a column to the predattrition dataframe containing the performance
      predattrition$performance=testing$last_evaluation

      predattrition$priority=predattrition$performance*predattrition$probaToLeave
      orderpredattrition=predattrition[order(predattrition$priority,decreasing = TRUE),]
      orderpredattrition <- head(orderpredattrition, n=input$noselect)
      or<- data.frame(orderpredattrition)
      or
    }
    else if(input$modelselect2== "Naives Bayes"){
      f1<-data()
      hr_model1 <- hr() %>% filter(left==0 |last_evaluation >= 0.70 | time_spend_company >= 4 | number_project > 5)
      hr_model1$left <- as.factor(hr_model1$left)
      train_control<- trainControl(method="cv", number=5, repeats=3)
      # Keep some data to test again the final model
      set.seed(100)
      inTraining <- createDataPartition(hr_model1$left, p = .75, list = FALSE)
      training <- hr_model1[ inTraining,]
      testing  <- hr_model1[-inTraining,]

      # Estimate the drivers of attrition
      e1071model2 = naiveBayes(left ~ ., data=training)
      # Make predictions on the out-of-sample data
      probaToLeave=predict( e1071model2,newdata=testing[,c(-7,-9,-10)],type="raw")
      # Structure the prediction output in a table
      predattrition = data.frame(probaToLeave)
      colnames(predattrition) <- c("c","probaToLeave")
      predattrition[1] <- NULL 
      # Add a column to the predattrition dataframe containing the performance
      predattrition$performance=testing$last_evaluation
      predattrition$priority=predattrition$performance*predattrition$probaToLeave
      orderpredattrition=predattrition[order(predattrition$priority,decreasing = TRUE),]
      orderpredattrition <- head(orderpredattrition, n=input$noselect)
      or<- data.frame(orderpredattrition)

    }

    else if(input$modelselect2== "Tree Learning"){
      f1<-data()
      hr_model1 <- hr() %>% filter(left==0 |last_evaluation >= 0.70 | time_spend_company >= 4 | number_project > 5)
      hr_model1$left <- as.factor(hr_model1$left)
      train_control<- trainControl(method="cv", number=5, repeats=3)
      # Keep some data to test again the final model
      set.seed(100)
      inTraining <- createDataPartition(hr_model1$left, p = .75, list = FALSE)
      training <- hr_model1[ inTraining,]
      testing  <- hr_model1[-inTraining,]
      # Estimate the drivers of attrition
      rpartmodel = rpart(left ~ satisfaction_level+last_evaluation+number_project+average_montly_hours+time_spend_company+Work_accident+promotion_last_5years,method = "anova",data=training)
      # Make predictions on the out-of-sample data
      probaToLeave=predict(rpartmodel,newdata=testing[,c(-7,-9,-10)],type="vector")
      # Structure the prediction output in a table
      predattrition = data.frame(probaToLeave)*0.5
      # Add a column to the predattrition dataframe containing the performance
      predattrition$performance=testing$last_evaluation

      predattrition$priority=predattrition$performance*predattrition$probaToLeave
      orderpredattrition=predattrition[order(predattrition$priority,decreasing = TRUE),]
      orderpredattrition <- head(orderpredattrition, n=input$noselect)

      or<- data.frame(orderpredattrition)
      or
    }
  )


  output$reportOutput = renderDataTable({
    rt()
  })

  output$downloadData <- downloadHandler(
    filename = function() { paste(input$modelselect2, '.csv', sep='') },
    content = function(file){
      write.csv(rt(), file)
    }
  )

}
shinyApp(ui=ui, server = server)

#2

using your example i was able to run the download and open the file when i changed:

rt <- reactive( ...

to

rt <- reactive({return(data.frame(quakes))})

reactive functions need ({ … }) otherwise it wont run on my pc
have you opened the .csv file rom server and verified correct dataframe has been written?

i am adding session info for you to check if any packages in your server are older:

> sessionInfo()
R version 3.4.1 (2017-06-30)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows >= 8 x64 (build 9200)

Matrix products: default

locale:
[1] LC_COLLATE=English_United Kingdom.1252  LC_CTYPE=English_United Kingdom.1252    LC_MONETARY=English_United Kingdom.1252 LC_NUMERIC=C                            LC_TIME=English_United Kingdom.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
[1] DT_0.2        ggplot2_2.2.1 tidyr_0.7.1   dplyr_0.7.4   e1071_1.6-8   shiny_1.0.5  

loaded via a namespace (and not attached):
 [1] Rcpp_0.12.12      bindr_0.1         magrittr_1.5      munsell_0.4.3     colorspace_1.3-2  xtable_1.8-2      R6_2.2.2          rlang_0.1.2       plyr_1.8.4        tools_3.4.1       grid_3.4.1       
[12] gtable_0.2.0      sourcetools_0.1.6 htmltools_0.3.6   class_7.3-14      yaml_2.1.14       lazyeval_0.2.0    assertthat_0.2.0  digest_0.6.12     tibble_1.3.4      bindrcpp_0.2      purrr_0.2.3      
[23] htmlwidgets_0.9   glue_1.1.1        mime_0.5          compiler_3.4.1    scales_0.5.0      jsonlite_1.5      httpuv_1.3.5      pkgconfig_2.0.1  


#3

Alternatively, you could use the DT::datatable function. There is already an excel download option included. See https://rstudio.github.io/DT/extensions.html


#4

This is an easy and robust solution :slight_smile:


#5

the buttons excel download extension will only download the table rows available at client side. For small tables this is ok since server will send all rows anyways however bigger tables will have only part at client side thus excel download will not export whole table from server. Changing settings in renderDataTable({},server=FALSE) will fix this however result in more data being send and stored in client browser causing performance issues. Nearly in all my apps i therefore use custom download handler.
Kind regards,
Peter


#6

Thanks, but I was only agreeing with @duringju211. They had the right answer :slight_smile:


#7

and yet still it is your post marked as solution :slight_smile: anyways i gave like to both since as you indicated, this is the best solution in probably majority of the cases.
rgds,
Peter


#8

Just wondering, if we can do that on our remote computer without having any legal issues. Is this legal… i am looking for the answer from last 1 month but lots of folks confused me that for hosting shiny app one should use shiny server and their services only (which are paid) and hosting the app on remote computer / local server would be risky and might involve any legal issues later for commercial purpose.

Your views would be greatly appreciated. Thanks in advance!