app.R

####################################### WELCOME TO THE SHINY APP ##################################
####################################### from Sandra K. (2023) #####################################
###################################################################################################

####################################### Load Script and Example-Dataset ###########################

source("zlog.R")
dataset_original <- read.csv("data/CALIPER.csv",na.strings="", fileEncoding="latin1")

####################################### Libraries #################################################

if("DT" %in% rownames(installed.packages())){
  library(DT)} else{
    install.packages("DT")
    library(DT)}

if("shinydashboard" %in% rownames(installed.packages())){
  library(shinydashboard)} else{
    install.packages("shinydashboard")
    library(shinydashboard)}

####################################### User Interface ############################################

ui <- dashboardPage(
  dashboardHeader(title = "Zlog_AdRI", titleWidth = 350),
  dashboardSidebar(
    width = 350,
    sidebarMenu(
      id = "sidebarid",
      
      div(
        style = "text-align:center",
        br(),
        "Tool for Plausibility Checks of Reference Interval Limits"
      ),
      
      uiOutput("dataset_file"),
      actionButton('reset', 'Reset Input', icon = icon("trash")),
      
      conditionalPanel(condition = "input.tabselected == 'Table'",
                       selectInput(
                         "sex",
                         "Select the sex:",
                         choices = c("Female (F)" = "F", "Male (M)" = "M")
                       )),
      conditionalPanel(
        condition = "input.tabselected == 'Plot'",
        selectInput(
          "sex_plot",
          "Select the sex:",
          choices = c("Female (F)" = "F", "Male (M)" = "M")
        )
      ),
      conditionalPanel(
        condition = "input.tabselected == 'Plot'",
        hr(),
        selectInput(
          "parameter",
          "Select the lab parameter:",
          choices = dataset_original$CODE,
          selected = TRUE
        )
      ),
      conditionalPanel(
        condition = "input.tabselected == 'Plot'",
        selectInput(
          "xaxis_scale",
          "Select the x-axis scaling:",
          choices = c(
            "Days" = "days",
            "Years" = "years",
            "Days/Years" = "days_years"
          ),
          selected = TRUE
        )
      ),
      conditionalPanel(
        condition = "input.tabselected == 'Plot'",
        checkboxInput("xlog", "Logarithmic scale for the x-axis", value = FALSE)
      ),
      
      hr(),
      
      div(
        style = "text-align:center",
        "For further information visit our",
        a("Website", href = "https://sandrakla.github.io/Zlog_AdRI/"),
        "or",
        br(),
        "read the publication",
        a("doi: 10.1515/cclm-2022-0688", href = "https://doi.org/10.1515/cclm-2022-0688"),
        "!"
      )
    )
  ),
  
  dashboardBody(fluidRow(
    tabBox(
      title = "Zlog_AdRI",
      id = "tabselected",
      width = 9,
      tabPanel(
        "Table",
        icon = icon("table"),
        
        p(
          "This Shiny App computes the zlog values of the preceding and the subsequent reference
              interval (RI) for different lab parameters for each age group. Many medical RI are
              not age-dependent and have large jumps between the individual age groups.
              This should be prevented by considering the zlog value. The zlog value should be optimally
              between -1.96 and 1.96. The further away the values, the more likely the RI jump is implausible."
        ),
        
        DT::dataTableOutput("table")
      ),
      
      tabPanel(
        "Plot",
        icon = icon("calculator"),
        
        p(
          "Original RI (top) and zlog values for the selected lab parameter for each age group (bottom).
              The direction of the triangles in the lower figure indicates the zlog values of the preceding (left) and the
              following age group (right).
              Blue color indicates lower, red the upper reference limits.
              The dotted green lines represent the common reference interval of -1.96 to +1.96.
              The further the traingles are from these lines, the more likely there is an implausible age jump."
        ),
        
        plotOutput("plot", height = "700px")
      )
    ),
    
    box(
      title = tagList(shiny::icon("info"), "Lab parameters with a value of 0:"),
      status = "info",
      width = 3,
      solidHeader = TRUE,
      
      htmlOutput("caution")
    ),
    
    box(
      title = tagList(shiny::icon("warning"), "High zlog values:"),
      status = "danger",
      width = 3,
      solidHeader = TRUE,
      
      numericInput(
        "maxzlog",
        "Maximum absolute zlog value:",
        10,
        min = 0,
        max = 50
      ),
      htmlOutput("helptext")
    ),
    
    box(
      title = tagList(shiny::icon("info"), "zlog Calculator"),
      status = "primary",
      width = 3,
      solidHeader = TRUE,
      
      p("Individual zlog values can be calculated here:"),
      
      numericInput("calculator_target_low", "Lower value:", value = NULL),
      numericInput("calculator_target_upper", "Upper value:", value = NULL),
      numericInput("calculator_x", "Value:", value = NULL),
      
      DT::dataTableOutput("calculator_table")
    )
  ))
)

####################################### Server ####################################################

server <- function(input, output, session) {
  
  options(shiny.plot.res=128)
  options(shiny.sanitize.errors = TRUE)
  options(warn = -1)
  
  ##################################### Reactive Expressions ######################################
  
  values <- reactiveValues(upload_state = NULL)
  
  observeEvent(input$dataset_file, {
    values$upload_state <- 'uploaded'
  })
  
  observeEvent(input$reset, {
    values$upload_state <- 'reset'
  })
  
  dataset_input <- reactive({
    if (is.null(values$upload_state)) {
      return(NULL)
    } else if (values$upload_state == 'uploaded') {
      return(input$dataset_file)
    } else if (values$upload_state == 'reset') {
      return(NULL)
    }
  })
  
  output$dataset_file <- renderUI({
    input$reset ## Create a dependency with the reset button
    fileInput("dataset_file","Upload CSV File:", accept = c("text/csv", "text/comma-separated-values,text/plain", ".csv"), multiple = FALSE)
  })
  
  get_data_file <- reactive({

    input$dataset_file
    
    saving <- 
      if(!is.null(dataset_input())){ 
        dataset_original <- read.csv(dataset_input()[["datapath"]], na.strings="", fileEncoding="latin1")
      }else{
        dataset_original <- read.csv("data/CALIPER.csv",na.strings="", fileEncoding="latin1")
      }
    return(dataset_original)
  })

  data_caution <- reactive({
  
    dat <- get_data_file()

    ### Check for upper and lower limit == 0
    indscri <- subset(1:nrow(dat),dat$LowerLimit==0)
    levscriage <- paste0(dat$CODE[indscri], " (", dat$AgeFrom[indscri], "-", dat$AgeUntil[indscri], " ", dat$UNIT[indscri], "s)")
    indscri2 <- subset(1:nrow(dat),dat$UpperLimit==0)
    levscri2age <- paste0(dat$CODE[indscri2], " (", dat$AgeFrom[indscri2], "-", dat$AgeUntil[indscri2], " ", dat$UNIT[indscri2], "s)")
    
    levscri <- levels(factor(dat$CODE[indscri]))
    levscri2 <- levels(factor(dat$CODE[indscri2]))
    
    if(length(levscri) <= 1){
        zero_lower <- paste("The Lower Limit (LL) for this lab parameter is zero:", toString(levscriage), ".")
        if(length(levscri) == 0){
            zero_lower <- ""
        }
    } else{
        zero_lower <- paste("The Lower Limit (LL) for these lab parameters is zero:", toString(levscriage), ".")
    }
    
    if(length(levscri2) <= 1){
      zero_upper <- paste("The Upper Limit (UL) for this lab parameter is zero:", toString(levscri2age), ".")
      if(length(levscri2) == 0){
        zero_upper <- ""
      }
    } else{
      zero_upper <- paste("The Upper Limit (UL) for these lab parameters is zero:", toString(levscri2age), ".")
    }
    
    text <- HTML(paste("<p>", zero_lower, zero_upper,"</p>"))
    
    if(zero_lower == "" && zero_upper == ""){
      text = "";
    }

    text
  })
  
  
  # Create the table with the zlog values as reactive expression 
  zlog_data <- reactive({
    
    dat <- get_data_file()
    
    validate(need(ncol(dat) == 8, 
                  "Check if you have used the correct template!"))
    
    # if(input$replacement == TRUE){
    #   
    #   # to prevent possible error messages because of the slow typing
    #   minv <- input$replace_low
    #   maxv.apc <- input$replace_upper
    #   
    #   validate(need(minv > 0, ""))
    #   validate(need(maxv.apc > 0, ""))
    # } 
    # else{
    #   minv <- 0.001 
    #   maxv.apc <- 100}
    
    ### Store the original data set.
    dat.orig <- dat
    
    ### Remove cases where both the lower and upper limits are not specified. 
    dat <- dat[!is.na(dat$LowerLimit) | !is.na(dat$UpperLimit),]
    
    ### Remove cases where the upper limit is 0.
    dat <- dat[dat$UpperLimit>0,]

    ### Use only complete cases.
    dat <- dat[complete.cases(dat),]
    
    ### For replacing missing values. (Not needed if only complete cases are used.)
    
    ### Not needed unless the previous line dat <- dat[complete.cases(dat),] is not applied.
    #dat$UpperLimit[is.na(dat$UpperLimit) | dat$UpperLimit==0] <- maxv.apc
    dat$LowerLimit[is.na(dat$LowerLimit) | dat$LowerLimit==0] <- NA
    
    ### Subset for the men. Note that the reference limits for men and for all are needed.
    datm <- subset(dat,dat$SEX=="M" | dat$SEX=="MF")
    ### Subset for the women. Note that the reference limits for men and for all are needed.
    datf <- subset(dat,dat$SEX=="F" | dat$SEX=="MF")
    ### Subset for the men and women. Note that the reference limits for men and for all are needed.
    datb <- dat
    
    ### Compute the zlog values of the preceding and subsequent reference limits etc. for men.
    datme <- compute.jumps(datm)
    ### Compute the zlog values of the preceding and subsequent reference limits etc. for women.
    datfe <- compute.jumps(datf)
    ### Compute the zlog values of the preceding and subsequent reference limits etc. for women and men.
    datbe <- compute.jumps(datb)
    
    ### Check the men or women and use the right dataset for datse
    
    if(input$tabselected == "Table"){
      if(input$sex == "M"){datse <- datme}
      if(input$sex == "F"){datse <- datfe}
      if(input$sex == "MF"){datse <- datbe}
    }
    if(input$tabselected == "Plot"){
      if(input$sex_plot == "M"){datse <- datme}
      if(input$sex_plot == "F"){datse <- datfe}
    }
    
    datse
 })

  ##################################### Observe Events ############################################
  
  observeEvent(input$dataset_file, {
    updateSelectInput(session, "parameter", choices = zlog_data()[,1])
  })
  
  ##################################### Output ####################################################

  helptext <- reactive({
    
    datse <- zlog_data()
    
    ### Check how many and where the absolute zlog value exceeds the given threshold.
    abslim <- input$maxzlog
    
    ### Indices of occurrences of large zlog values.
    indscri <- subset(1:nrow(datse),datse$max.abs.zlog>abslim)
    
    ### Names of the lab parameters where large zlog values occur.
    levscri <- levels(factor(datse$CODE[indscri]))
    
    ### No. of occurrences of large zlog values.
    if(length(levscri) == 1){
      text <- HTML(paste("<p>", sum(datse$max.abs.zlog>abslim, na.rm = TRUE), "zlog values above", abslim,
                  "from this lab parameter:", toString(levscri), "</p>"))}
    else{
      text <- HTML(paste("<p>", sum(datse$max.abs.zlog>abslim, na.rm = TRUE), "zlog values above", abslim,
                  "from these lab parameters:", toString(levscri), "</p>"))
    }
    
    if(length(levscri) == 0){
      text <- HTML(paste("<p> No zlog value is above", abslim),".</p>")
    }
    
    text
  })
  
  
  output$caution <- renderUI({ data_caution() })
 
  output$helptext <- renderUI({ helptext() })
  
  output$plot <- renderPlot({
    
    datme <- zlog_data()
    #cairo_ps(file = "Figure1.eps", onefile = FALSE, fallback_resolution = 1200)
    
    ### Draw the graphs for zlog and original reference limits in one figure.
    par(mfrow=c(2,1), mai=c(0.95,0.95,0.15,0.15))
    
    ### Draw the graphs for the given lab parameter
    lab.param <- input$parameter
    
    # to prevent possible error messages because of the slow typing
    validate(need(length(subset(1:nrow(datme),datme$CODE==input$parameter)) > 0, ""))
    
    # check for log for the xaxis
    xlog_ <- input$xlog
    xaxis_scale_ <- input$xaxis_scale
    
    if(xaxis_scale_ == "days_years"){
      par(mfrow=c(2,1), mai=c(1.5,0.95,0.15,0.15))
    }
    
    # Draw the plots
    draw.time.dependent.lims(datme,lab.param, use.zlog=F,lwd.reflims=2,xlog=xlog_, xaxis_scale = xaxis_scale_)
    draw.time.dependent.lims(datme,lab.param, lwd.reflims=2,xlog=xlog_, xaxis_scale = xaxis_scale_)
    #dev.off()
  })

  output$table <- DT::renderDataTable({
    
    datme <- zlog_data()

    datme <- data.frame(CODE = datme$CODE, SEX = datme$SEX, AGE = 
                          paste0(datme$AgeFrom, "-", datme$AgeUntil, " (", datme$UNIT, "s)"), 
                          round_df(datme[,seq(7,length(datme))],3))
    
    datme$start.time.d <- NULL
    colnames(datme) <- c("Code", "Sex", "Age", "Lower Limit", "Upper Limit", "Prev.lower zlog",
                         "Prev.upper zlog", "Next.lower zlog", "Next.upper zlog", "Max.abs.zlog")

    options(htmlwidgets.TOJSON_ARGS = list(na = 'string'))
     
    # if(input$replacement == TRUE){
    #   DT::datatable(datme, rownames= FALSE, extensions = 'Buttons',
    #                 options = list(dom = 'Blfrtip', pageLength = 15, buttons = c('copy', 'csv', 'pdf', 'print')),
    #                 caption = htmltools::tags$caption(style = 'caption-side: bottom; text-align: center;', 
    #                                                   'Table: Dataset with the zlog values')) %>%
    #     DT:: formatStyle(columns = "Prev.lower zlog", color = styleEqual(datme[,5], highzlogvalues(c(datme[,5]))),
    #                      backgroundColor =  styleEqual(datme[,5], zlogcolor(c(datme[,5])))) %>%
    #     DT:: formatStyle(columns = "Prev.upper zlog", color = styleEqual(datme[,6], highzlogvalues(c(datme[,6]))),
    #                      backgroundColor =  styleEqual(datme[,6], zlogcolor(c(datme[,6])))) %>%
    #     DT:: formatStyle(columns = "Next.lower zlog", color = styleEqual(datme[,7], highzlogvalues(c(datme[,7]))),
    #                      backgroundColor =  styleEqual(datme[,7], zlogcolor(c(datme[,7])))) %>%
    #     DT:: formatStyle(columns = "Next.upper zlog", color = styleEqual(datme[,8], highzlogvalues(c(datme[,8]))),
    #                      backgroundColor =  styleEqual(datme[,8], zlogcolor(c(datme[,8])))) %>%
    #     DT:: formatStyle(columns = "Max.abs.zlog", color = styleEqual(datme[,9], highzlogvalues(c(datme[,9]))),
    #                      backgroundColor =  styleEqual(datme[,9], zlogcolor(c(datme[,9]))))
    #   
    # }
    # else{
    #   DT::datatable(datme, rownames= FALSE, extensions = 'Buttons',
    #                 options = list(dom = 'Blfrtip', pageLength = 15, buttons = c('copy', 'csv', 'pdf', 'print')),
    #                 caption = htmltools::tags$caption(style = 'caption-side: bottom; text-align: center;', 
    #                                                   'Table: Dataset with the zlog values')) %>%
    #     DT:: formatStyle(columns = "Prev.lower zlog", color =  styleEqual(datme[,5], highzlogvalues(c(datme[,5]))),
    #                      backgroundColor =  styleEqual(datme[,5], zlogcolor(c(datme[,5])))) %>%
    #     DT:: formatStyle(columns = "Prev.upper zlog", color =  styleEqual(datme[,6], highzlogvalues(c(datme[,6]))),
    #                      backgroundColor =  styleEqual(datme[,6], zlogcolor(c(datme[,6])))) %>%
    #     DT:: formatStyle(columns = "Next.lower zlog", color =  styleEqual(datme[,7], highzlogvalues(c(datme[,7]))),
    #                      backgroundColor =  styleEqual(datme[,7], zlogcolor(c(datme[,7])))) %>%
    #     DT:: formatStyle(columns = "Next.upper zlog", color =  styleEqual(datme[,8], highzlogvalues(c(datme[,8]))),
    #                      backgroundColor =  styleEqual(datme[,8], zlogcolor(c(datme[,8])))) %>%
    #     DT:: formatStyle(columns = "Max.abs.zlog",color = styleEqual(datme[,9], highzlogvalues(c(datme[,9]))),
    #                      backgroundColor =  styleEqual(datme[,9], zlogcolor(c(datme[,9]))))
    #     }
    
    # if(input$replacement == TRUE){
    #   DT::datatable(datme, rownames= FALSE, extensions = 'Buttons',
    #                 options = list(dom = 'Blfrtip', pageLength = 15, buttons = c('copy', 'csv', 'pdf', 'print')),
    #                 caption = htmltools::tags$caption(style = 'caption-side: bottom; text-align: center;',
    #                                                   'Table: Dataset with the zlog values')) %>%
    #     DT:: formatStyle(columns = "Max.abs.zlog", color = styleEqual(datme[,10], highzlogvalues(c(datme[,10]))),
    #                      backgroundColor =  styleEqual(datme[,10], zlogcolor(c(datme[,10]))))

    #}
    #else{
      DT::datatable(datme, rownames= FALSE, extensions = 'Buttons',
                    options = list(dom = 'Blfrtip', pageLength = 15, buttons = c('copy', 'csv', 'pdf', 'print')),
                    caption = htmltools::tags$caption(style = 'caption-side: bottom; text-align: center;',
                                                      'Table: Dataset with the zlog values')) %>%
        DT:: formatStyle(columns = "Max.abs.zlog",color = styleEqual(datme[,9], highzlogvalues(c(datme[,10]))),
                         backgroundColor =  styleEqual(datme[,10], zlogcolor(c(datme[,10]))))
        #}
  })

  output$calculator_table <- DT::renderDataTable({

    zlog_value <- zlog(as.numeric(input$calculator_x), 
                        as.numeric(input$calculator_target_low), 
                        as.numeric(input$calculator_target_upper))
    
    datme <- data.frame("Lower value" = input$calculator_target_low, 
                        "Upper value" = input$calculator_target_upper, Value = input$calculator_x, 
                        "zlog" = round_df(zlog_value, 3), check.names = FALSE)
    
    options(htmlwidgets.TOJSON_ARGS = list(na = 'string'))
  
    DT::datatable(datme, rownames= FALSE, options = list(dom = 't')) %>%
      DT:: formatStyle(columns = "zlog",color = styleEqual(datme[,4], highzlogvalues(c(datme[,4]))),
                       backgroundColor =  styleEqual(datme[,4], zlogcolor(c(datme[,4]))))
  })
  
  # output$download_data <- downloadHandler(
  #   filename = function(){
  #     paste0("Table_Zlog.csv")
  #   },
  #   content = function(file) {
  #     
  #     datme <- zlog_data()
  #     datme <- data.frame(CODE = datme$CODE, SEX = datme$SEX, UNIT = datme$UNIT, 
  #                         round_df(datme[,seq(7,length(datme))],3))
  #     
  #     colnames(datme) <- c("Code", "Sex", "Unit", "Lower Limit", "Upper Limit", "Age", "Prev.lower zlog",
  #                          "Prev.upper zlog", "Next.lower zlog", "Next.upper zlog", "Max zlog")
  #     
  #     write.csv(datme, file, row.names = FALSE)
  #   })
  
  # output$download_data_example <- downloadHandler(
  #   filename = function(){
  #     paste0("Table_CALIPER.csv")
  #   },
  #   content = function(file) {
  #     
  #     dataset_original <- read.csv("data/CALIPER.csv",na.strings="")
  #     write.csv(datme, file, row.names = FALSE)
  #   })
}
####################################### Run the application #######################################
shinyApp(ui = ui, server = server)