inst/shiny-apps/CORRANA/server.R

function(input, output, session) {

  # Reload app if disconnected
  observeEvent(input$disconnect, {
    session$close()
  })

  # Reload app button
  observeEvent(input$reload,session$reload())

  # On session end
  session$onSessionEnded(stopApp)

  # Upload message
  observeEvent(input$file, {
    showModal(modalDialog(
      title = "Reading Data", "Please Wait",
      footer = NULL,
      fade = FALSE,
      easyClose = TRUE,
    ))
    Sys.sleep(2)
  }, priority=100)


  # Upload data
  datainput <- reactive({


    ###############
    # Validations
    ###############

    validate(need(input$file$datapath != "", "Please upload a CSV file."))

    validate(need(tools::file_ext(input$file$datapath) == "csv", "Error. Not a CSV file. Please upload a CSV file."))


    if (input$fencoding == "unknown"){

      validate(need(try(datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "unknown",
                                            data.table = FALSE, na.strings = "")),
                    "Error. File cannot be read. Please check that the file is not empty, fully whitespace, or skip has been set after the last non-whitespace."))

      validate(need(tryCatch(datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "unknown",
                                           data.table = FALSE, na.strings = ""), warning=function(w) {}),
                    "Error. The file cannot be read unambigously. Consider changing the characters for the field separator, quote or decimal. Remove blank lines. "
                    ))

      validate(need(try(iconv(colnames(datainput1), guess_encoding(input$file$datapath)[[1]][1], "UTF-8")),
                        "Error. There is a problem with the selected encoding. Please revise your data and/or try the other encoding option."))


      validate(need(try(sapply(datainput1[, sapply(datainput1, is.character)], function(col) iconv(col, guess_encoding(input$file$datapath)[[1]][1], "UTF-8"))),
                        "Error. There is a problem with the selected encoding. Please revise your data and/or try the other encoding option."))

    }

   if (input$fencoding == "UTF-8"){

      validate(
       need(guess_encoding(input$file$datapath)[[1]][1] %in% c("UTF-8","ASCII") &
               guess_encoding(input$file$datapath)[[2]][1] > 0.9,
             "Error. The file is probably not UTF-8 encoded. Please convert to UTF-8 or try the automatic encoding option.")
      )

      validate(need(try(datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "UTF-8",
                                  data.table = FALSE, na.strings = "")), "Error. File cannot be read. Please check that the file is not empty, fully whitespace, or skip has been set after the last non-whitespace."))


      validate(need(tryCatch(datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "unknown",
                                                 data.table = FALSE, na.strings = ""), warning=function(w) {}),
                    "Error. The file cannot be read unambigously. Consider changing the characters for the field separator, quote or decimal. Remove blank lines. "
      ))

   }



   if (is.null(input$file))
      return(NULL)


    ###############
    # Datainput code
    ################



    return(tryCatch(


      if (input$fencoding == "UTF-8" & input$decimal == "auto"){

        datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "UTF-8", data.table = FALSE, na.strings = "")

        # Probably comma as decimal
        colnames <- sapply(datainput1, function(col) is.numeric(col) & Negate(is.integer)(col))
        if (sum(colnames) == 0L){

          datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=",", encoding = "UTF-8", data.table = FALSE, na.strings = "")
          datainput1

        } else {datainput1}

      } else if (input$fencoding == "UTF-8" & input$decimal != "auto") {

        datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=input$decimal, encoding = "UTF-8", data.table = FALSE, na.strings = "")
        datainput1


      } else if (input$fencoding == "unknown" &  input$decimal == "auto"){

        enc_guessed <- guess_encoding(input$file$datapath)
        enc_guessed_first <- enc_guessed[[1]][1]
        datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=".", encoding = "unknown", data.table = FALSE, na.strings = "")

        # Probably comma as decimal
        colnames <- sapply(datainput1, function(col) is.numeric(col) & Negate(is.integer)(col))
        if (sum(colnames) == 0L){

          datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec=",", encoding = "unknown", data.table = FALSE, na.strings = "")
          colnames(datainput1) <- iconv(colnames(datainput1), enc_guessed_first, "UTF-8")
          col_names <- sapply(datainput1, is.character)
          datainput1[ ,col_names] <- sapply(datainput1[, col_names], function(col) iconv(col, enc_guessed_first, "UTF-8"))
          datainput1

        } else {

          colnames(datainput1) <- iconv(colnames(datainput1), enc_guessed_first, "UTF-8")
          col_names <- sapply(datainput1 , is.character)
          datainput1[ ,col_names] <- sapply(datainput1[, col_names], function(col) iconv(col, enc_guessed_first, "UTF-8"))
          datainput1}

      } else {

        enc_guessed <- guess_encoding(input$file$datapath)
        enc_guessed_first <- enc_guessed[[1]][1]
        datainput1 <- fread(input$file$datapath, header = "auto", sep="auto", dec = input$decimal, encoding = "unknown", data.table = FALSE, na.strings = "")
        colnames(datainput1) <- iconv(colnames(datainput1), enc_guessed_first, "UTF-8")
        col_names <- sapply(datainput1, is.character)
        datainput1[ ,col_names] <- sapply(datainput1[, col_names], function(col) iconv(col, enc_guessed_first, "UTF-8"))
        datainput1

      }

      ,error=function(e) stop(safeError(e))

    ))


  })



  # Row limits
  observe({

    req(input$file, datainput())

    removeModal()


    if (nrow(datainput()) > 5000){
      showNotification("Maximum sample size exceeded. For more contact: support@statsomat.com", duration=30)
      Sys.sleep(5)
      session$close()
    }

    if (nrow(datainput()) < 7){
      showNotification("Error: Minimum 7 observations required. ", duration=30)
      Sys.sleep(5)
      session$close()
    }


  })



  # Select Variables
  output$selection1 <- renderUI({

    req(datainput())

    removeModal()

    chooserInput("selection1", "Available", "Selected",
                 colnames(datainput()), c(), size = 15, multiple = TRUE)

  })


  # Other limits
  observe({

    req(input$file, datainput())

    removeModal()

    if (length(unique(input$selection1$left)) != length(input$selection1$left)){

      showNotification("Error: The columns names are not distinct. The session will be restarted. ", duration=30)
      Sys.sleep(5)
      session$close()

    }


    if (length(input$selection1$right) > 10 ){

      showNotification("Maximum number of columns exceeded. For more contact: support@statsomat.com", duration=30)
      Sys.sleep(5)
      session$close()

    }

  })


  # This creates a short-term storage location for a filepath
  report <- reactiveValues(filepath = NULL)

  # Render report
  observeEvent(input$generate, {

    req(input$file, datainput(), input$selection1$right)

    src0 <- normalizePath('report_kernel.Rmd')
    src1 <- normalizePath('report.Rmd')
    src4 <- normalizePath('references.bib')
    src5 <- normalizePath('report_code_unknown.Rmd')
    src6 <- normalizePath('report_code_common.Rmd')
    src7 <- normalizePath('report_code_UTF8.Rmd')
    src8 <- normalizePath('FiraSans-Bold.otf')
    src9 <- normalizePath('FiraSans-Regular.otf')


    # Temporarily switch to the temp dir
    owd <- setwd(tempdir())
    on.exit(setwd(owd))
    file.copy(src0, 'report_kernel.Rmd', overwrite = TRUE)
    file.copy(src1, 'report.Rmd', overwrite = TRUE)
    file.copy(src4, 'references.bib', overwrite = TRUE)
    file.copy(src5, 'report_code_unknown.Rmd', overwrite = TRUE)
    file.copy(src6, 'report_code_common.Rmd', overwrite = TRUE)
    file.copy(src7, 'report_code_UTF8.Rmd', overwrite = TRUE)
    file.copy(src8, 'FiraSans-Bold.otf', overwrite = TRUE)
    file.copy(src9, 'FiraSans-Regular.otf', overwrite = TRUE)


    # Set up parameters to pass to Rmd document
    enc_guessed <- guess_encoding(input$file$datapath)
    enc_guessed_first <- enc_guessed[[1]][1]

    params <- list(data = datainput(), filename=input$file, fencoding=input$fencoding, decimal=input$decimal, enc_guessed = enc_guessed_first,
                   vars1 = input$selection1$right)


    tryCatch({

      withProgress(message = 'Please wait, the Statsomat app is computing. This may take a while.', value=0, {

        for (i in 1:40) {
          incProgress(1/40)
          Sys.sleep(0.25)

        }

        if (input$rcode == "No"){

          tmp_file <- render('report.Rmd', pdf_document(latex_engine = "xelatex"),
                        params = params,
                        envir = new.env(parent = globalenv())
          )

        } else {

          if (input$fencoding == "UTF-8"){

            tmp_file <- render('report_code_UTF8.Rmd', pdf_document(latex_engine = "xelatex"),
                          params = params,
                          envir = new.env(parent = globalenv())

            )} else {tmp_file <- render('report_code_unknown.Rmd', pdf_document(latex_engine = "xelatex"),
                                   params = params,
                                   envir = new.env(parent = globalenv())
            )}

        }

        report$filepath <- tmp_file

      })

      showNotification("Now you can download the report. ",duration=20)

    },

    error=function(e) {
      # Usually Latex errors catched here
      showNotification("Something went wrong. Please contact the support@statsomat.com.", duration=10)
      }
    )

  })


  # Enable downloadbutton
  observe({
    req(!is.null(report$filepath))
    session$sendCustomMessage("check_generation", list(check_generation  = 1))
  })


  # Download report
  output$download <- downloadHandler(

    filename = function() {
      paste('MyReport',sep = '.','pdf')
    },

    content = function(file) {

      file.copy(report$filepath, file)

    }
  )


}

Try the Statsomat package in your browser

Any scripts or data that you put into this service are public.

Statsomat documentation built on Nov. 17, 2021, 5:17 p.m.