inst/app/mod_loadNcheck.R

In PascalCrepey/HospitalNetwork: Building Networks of Hospitals Through Patients Transfers

# Module UI
  
#' @title   mod_loadNcheck_ui and mod_loadNcheck_server
#' @description  Module to load the database, perform checks, and print messages, warnings, and errors. Server returns the cleaned database.
#'
#' @param id shiny id
#' @param input internal
#' @param output internal
#' @param session internal
#'
#' @rdname mod_loadNcheck
#'
#' @keywords internal
#' @export 
#' @importFrom shiny NS tagList
#' @import shinyWidgets

mod_loadNcheck_ui <- function(id) {
  ns <- NS(id)
  sbPan = sidebarPanel(
    tabsetPanel(
      tabPanel(title = "Upload and check dataset",
               fileInput(ns("dataset"),
                         "File",
                         buttonLabel = HTML(paste(icon("upload",  ), "Browse"))),
               fluidRow(
                 column(5, HTML("<b>File format</b>")),
                 column(7, 
                        shinyWidgets::radioGroupButtons(ns("filetype"),
                                                        choices = c("CSV", "Rdata", "RDS"),
                                                        status = "default",
                                                        size = "sm",
                                                        selected = NA)
                 )
               ),
               uiOutput(ns("checkUI"))
      ),
      tabPanel(title = "Fake dataset", 
               sliderInput(ns("fd_n_subjects"), "Number of subjects", 
                           min = 100, max = 10000, value = 1000),
               sliderInput(ns("fd_n_facilities"), "Number of facilities",
                           min = 2, max = 1000, value = 10),
               uiOutput(ns("fd_n_clustersUI")),
               div(style = "display: inline-block;vertical-align:top;",
                   actionButton(ns("buildFD"),
                                "Build base",
                                icon = icon("data-base"),
                                style = "color: #fff; background-color: #337ab7; border-color: #2e6da4")
               )
      )
    ),
    shinyjs::hidden(uiOutput(ns("downloadNgoto")))
  )

  sidebarLayout(
      mainPanel = mainPanel(
        uiOutput(ns("intro_md"))
      ),          
      sidebarPanel = sbPan,
      position = "right")

}
    
# Module Server
    
#' @rdname mod_loadNcheck
#' @export
#' @keywords internal
    
mod_loadNcheck_server <- function(input, output, session, parent, mainData){
    ns <- session$ns

    ## Reactive value to store the checked database
    base = reactiveVal()
    
    output$intro_md <- renderUI({
      includeMarkdown("inst/intro.md")
    })

    #--- Load file ----------------------------------------------------    
    dataset = reactive({
        req(input$dataset)
    })
    output$fileUploaded <- reactive({
        return(!is.null(dataset()))
    })
    outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
    
    #where we put the main datatable
    datatable = reactiveVal(NULL)
    #--- Read file depending on type ----------------------------------
    observeEvent(input$filetype,{
      req(input$filetype)
      #reset the base
      base(NULL)
      user_file = dataset()$datapath
      if (input$filetype == "CSV") {
        datatable(fread(user_file))
      }
      else if (input$filetype == "Rdata") {
          e = new.env()
          dtb = load(user_file, envir = e)
          datatable(e[[dtb]])
      }
      else {
        datatable(readRDS(user_file))
      }
    })
    
    # Generate the fake data ----
    observeEvent(input$buildFD, {
      withProgress(message = "Building fake data...",{
        if (input$fd_n_clusters == 1){
          print("build fake data with single cluster")
          db = create_fake_subjectDB(n_subjects = input$fd_n_subjects,
                                     n_facilities = input$fd_n_facilities,
                                     with_errors = FALSE)
          incProgress(amount = 0.5, detail = "data generated")
        }else{
          print("build fake data with multiple clusters")
          db = create_fake_subjectDB_clustered(n_subjects = input$fd_n_subjects, 
                                               n_facilities = input$fd_n_facilities,
                                               n_clusters = input$fd_n_clusters)
          incProgress(amount = 0.5, detail = "clustered data generated")
        }
        #output the base
        base(HospitalNetwork::checkBase(base = db))
        
        incProgress(amount = 0.5, detail = "data checked")
      })
      #update message board
      mainData$notifications = makeNotification(mainData$notifications, 
                                                mtype = "database", 
                                                micon = "battery-full", 
                                                mtext = "fake database loaded.")
      mainData$notifications = makeNotification(mainData$notifications, 
                                                mtype = "datafile", 
                                                micon = "file", 
                                                mtext = paste0("dataset: ",
                                                               input$fd_n_subjects,"/",
                                                               input$fd_n_facilities,"/",
                                                               input$fd_n_clusters))

      shinyalert::shinyalert(title = "Fake database built successfully",
                             text = paste0("The database containing ",
                                           input$fd_n_subjects, " subjects, ",
                                           input$fd_n_facilities, " facilities, and ",
                                           input$fd_n_clusters, " clusters has been built."),
                             type = "success")
      
      shinyjs::show(id = "downloadNgoto")

    })

    previously_checked = eventReactive(input$filetype, {
        inherits(datatable(), "hospinet.base")
    })
    
    ##--- Conditional UI to check database -----------------------------------
    output$checkUI = renderUI({
        req(input$filetype)
        req(input$dataset)
        validate(need(class(try(datatable())) != "try-error",
                      message = "Error reading file. Please verify file format"))
        validate(need("data.frame" %in% class(datatable()),
                      message = "Error: data provided is not a data.frame or data.table"))
        validate(need(ncol(datatable()) >= 4,
                      message = "Error: dataset must have at least 4 columns"))
        cols = colnames(datatable())
        conditionalUI = if (input$filetype == "CSV" |
                            (input$filetype == "Rdata" & !previously_checked()) |
                            (input$filetype == "RDS" & !previously_checked())) {
                            list(
                                fluidRow(
                                    column(5, HTML("<b>Subject identifier:</b>")),
                                    column(7, selectInput(ns("sID"),
                                                          label = NULL,
                                                          choices = cols,
                                                          selected = cols[1]))
                                ),
                                fluidRow(
                                    column(5, HTML("<b>Facility identifier:</b>")),
                                    column(7, selectInput(ns("fID"),
                                                          label = NULL,
                                                          choices = cols,
                                                          selected = cols[2]))
                                ),
                                fluidRow(
                                    column(5, HTML("<b>Admission date</b>")),
                                    column(7, selectInput(ns("adate"),
                                                          label = NULL,
                                                          choices = cols,
                                                          selected = cols[3]))
                                ),
                                fluidRow(
                                    column(5, HTML("<b>Discharge date</b>")),
                                    column(7, selectInput(ns("ddate"),
                                                          label = NULL,
                                                          choices = cols,
                                                          selected = cols[4]))
                                ),
                                fluidRow(
                                    column(5, HTML("<b>Date format</b>")),
                                    column(7, selectInput(ns("dateformat"),
                                                          label = NULL,
                                                          choices = c("Year-Month-Day" = "ymd",
                                                                      "Year-Day-Month" = "ydm",
                                                                      "Month-Day-Year" = "mdy",
                                                                      "Day-Month-Year" = "dmy",
                                                                      "Day-Year-Month" = "dym",
                                                                      "Month-Year-Day" = "myd"),
                                                          selected = "Year-Month-Day"))
                                ),
                                fluidRow(
                                    column(5, HTML("<b>Time format</b>")),
                                    column(7, selectInput(ns("timeformat"),
                                                          label = NULL,
                                                          choices = c("None" = "",
                                                                      "Hours-Minutes-Seconds" = "HMS",                                                                    "Hours-Minutes-Seconds" = "HMS",
                                                                      "Seconds-Minutes-Hours" = "SMH",
                                                                      "Hours-Minutes" = "HM"),
                                                          selected = "None"))
                                ),
                                shinyWidgets::awesomeRadio(ns("deletemissing"),
                                             "Remove missing values?",
                                             choices = c("No" = "No",
                                                         "Remove record" = "record",
                                                         "Remove patient" = "patient"),
                                             inline = TRUE),
                                shinyWidgets::awesomeRadio(ns("deleteerrors"),
                                             "Remove erroneous records?",
                                             choices = c("No" = "No",
                                                         "Remove record" = "record",
                                                         "Remove patient" = "patient"),
                                             inline = TRUE)
                            )
                        } else {
                            NULL
                        }
        startUI = list(
            div(style="display: inline-block;vertical-align:top;",
                actionButton(ns("start"),
                             "Check base",
                             icon = icon("search"),
                             style="color: #fff; background-color: #337ab7; border-color: #2e6da4")
                )            
        )
        return(conditionalPanel(paste0("output['", ns("fileUploaded"), "']"),
                                c(conditionalUI, startUI)))
    })
    
    output$downloadNgoto <- renderUI({
      dgUI = div(style="display: inline-block;vertical-align:top;padding-top:10px",
                           downloadButton(ns("downloadCheckedBase"),
                                          label = "Download checked base"),
                           actionButton(ns("goToConstruct"), "go to network", icon = icon("forward"))
      )
      return(dgUI)
    })

    #--- Set arguments ------------------------------------------------
    args = reactive({
        list(deleteMissing = if(input$deletemissing == "No") NULL else input$deletemissing,
             deleteErrors = if(input$deleteerrors == "No") NULL else input$deleteerrors,
             datetimeformat = paste0(input$dateformat, input$timeformat))
    })
    
    #--- Check dataset, with error/message/warning catch ---------------
    savedMsg = c()
    savedWar = c()
    checked = eventReactive(input$start, {
        base(NULL)
        if (!previously_checked()) {
        out = withCallingHandlers(
            try(HospitalNetwork::checkBase(base = datatable(),
                                           convertDates = TRUE,
                                           dateFormat = args()$datetimeformat,
                                           deleteMissing = args()$deleteMissing,
                                           deleteErrors = args()$deleteErrors,
                                           subjectID = input$sID,
                                           facilityID = input$fID,
                                           admDate = input$adate,
                                           disDate = input$ddate,
                                           returnReport = TRUE,
                                           verbose = TRUE)),
            message = function(e) {
                savedMsg <<- c(savedMsg, conditionMessage(e))
            },
            warning = function(w) {
                savedWar <<- c(savedWar, warningCondition(w))
            }
        )
        return(out)
        } else {
            return(NULL)
        }
    })

    #--- Success or failure ---------------------------
    observeEvent(input$start, {
        savedMsg <<- c()
        savedWar <<- c()
        out = checked()
        if (previously_checked()) {
            base(datatable())
          #browser()
            #update message board
            mainData$notifications = makeNotification(mainData$notifications, 
                                                      mtype = "database", 
                                                      micon = "battery-full", 
                                                      mtext = "database checked and loaded.")
            mainData$notifications = makeNotification(mainData$notifications, 
                                                      mtype = "datafile", 
                                                      micon = "file", 
                                                      mtext = paste0("dataset: ",dataset()$name))
            #browser()
            shinyalert::shinyalert(title = "Database previously checked",
                                   text = "The database was not checked again",
                                   type = "success")
            shinyjs::show(id = "downloadNgoto")
        } else if ("try-error" %in% class(out)) {
            shinyalert::shinyalert(title = "Error",
                                   text = paste0("<div align=left>",
                                                 paste(paste(savedMsg, collapse = "</br>"),
                                                       "</br><b>", savedWar[[1]], "</br>",
                                                       "</br><b>", out[[1]], "</b>"),
                                                 "</div><br/>"),
                                   type = "error",
                                   html = TRUE)
        } else {
            base(checked())
            totaldeleted = sum(unlist(attr(base(), "report")[c("removedErrors",
                                                               "removedMissing",
                                                               "removedDuplicates")]
                                      )
                               )
            #update message board
            mainData$notifications = makeNotification(mainData$notifications, mtype = "database", micon = "battery-full",
                             mtext = "database checked and loaded !")
            mainData$notifications = makeNotification(mainData$notifications, 
                                                      mtype = "datafile", 
                                                      micon = "file", 
                                                      mtext = paste0("dataset: ",dataset()$name))
            
            shinyalert::shinyalert(title = "Checked",
                                   text = HTML(paste0("<div align=left>",
                                                      paste(savedMsg, collapse = "<br/>"),
                                                      "</div><br/>",
                                                      "<p style='color:salmon'><b>",savedWar[[1]], "</b></p></br>",
                                                      paste0("<b>Total number of deleted records: ", totaldeleted, "</b>"))),
                                   type = "success",
                                   html = TRUE)
            shinyjs::show(id = "downloadNgoto")
        }
    })

    ## ##--- Propose to download cleaned data ---------------------------

    
    observeEvent(input$goToConstruct, {
      shinydashboard::updateTabItems(session = parent, inputId = "mainSidebar", selected = "construct")
    })
    output$downloadCheckedBase <- downloadHandler(
        filename = function() {
          "checked_database.RDS"
        },
        content = function(file) {
            saveRDS(base(), file)
        }
    )

    # Fake data UI ----
    output$fd_n_clustersUI <- renderUI({
      sliderInput(ns("fd_n_clusters"), "number of clusters", 
                  min = 1, 
                  max = input$fd_n_facilities, step = 1,
                  value = 1)
    })
    


    ##--- RETURN ------------------------------------------------------
    return(reactive({base()}))


}
    
## To be copied in the UI
# mod_loadNcheck_ui("loadNcheck_ui_1")
    
## To be copied in the server
# callModule(mod_loadNcheck_server, "loadNcheck_ui_1")