Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Why I do not get my data under the Load Panel? #991

Closed
gabrielburcea opened this issue Feb 15, 2023 · 4 comments
Closed

Why I do not get my data under the Load Panel? #991

gabrielburcea opened this issue Feb 15, 2023 · 4 comments

Comments

@gabrielburcea
Copy link

gabrielburcea commented Feb 15, 2023

I am having two tabs in the navigation bar (I am trying to keep it simple, I have more, but won't matter). Now, I get my info tab the way I want it. But when I upload the module for load data, I cannot get it under 'Load Data' tab but rather under the first tab - Info .

Here is a snipped of the code (although full repo is available on the request -https://github.com/gabrielburcea/grwtgolem, it is golem shiny framework and would like to keep it this way.

First, I define app_ui :

app_ui <- function(request) {
  tagList(# Leave this function for adding external resources
    golem_add_external_resources(),
    shinyjs::useShinyjs(),
    
    # Your application UI logic
    shinyUI(
      shiny::navbarPage(title = div(tags$a(img(src = "www/AZ_SYMBOL_RGB.png", height = "50px"), "Growth Rate Explorer"),
                                    id = "navBar",
                                    theme = "www/style.css",
                                    # collapsible = TRUE,
                                    # inverse = TRUE,
                                    style = "position: relative; top: -30px; margin-left: 10px; margin-top: 5px;"),
                        header = tags$head(includeCSS("www/style.css")),# sourcing css style sheet
                        # make navigation bar collapse on smaller screens
                        windowTitle = "Growth Rate Explorer",
                        collapsible = TRUE,
                        
                        shiny::tabPanel("Info", icon = icon("fa-light fa-info"), mod_info_app_ui("info_app_1")),
                        
                        shiny::tabPanel("Load Data", icon = icon("fa-light fa-database"), mod_load_app_ui("load_app_1"))
                        
      )
    )
  )
}

And then, I define the server_app as:

#' app_server
#'
#' @param input,output,session Internal parameters for {shiny}.
#'     DO NOT REMOVE.
#' @import shiny
#' @noRd
app_server <- function(input, output, session){

  mod_info_app_server("info_app_1")
  mod_load_app_server("load_app_1")
 
}

To reiterate, I get my load app under the info tab. Why is this happening?

I have tried for the last two days different configuration but nothing helped.

I tried to re-define the app_server with the shiny::callModule(mod_load_server, mod_load_ui_1) and it did not work whatsoever.

For your info: mod_info_app and mod_load_app:

First is mod_info_app that contains html scripts (which I won't provide, these are way too big) but this module defines the ui and server for info tab, just as golem requires:

#'mod_info_app_ui UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_info_app_ui <- function(id){
  ns <- NS(id)
    tagList(shiny::tabPanel(title = "Info",
                            icon = icon("fa-light fa-info"),
                            value = "Info",
                            tags$div(
                              class = "main",
                              shiny::fluidPage(
                                htmltools::htmlTemplate("www/welcome_to_growth_rate_explorer.html"),
                                htmltools::htmlTemplate("www/info_tabs_list.html")
                              )
                            )))


  # )
}

#' mod_info_app_server Server Functions
#'
#' @noRd
mod_info_app_server <- function(id){
  moduleServer( id, function(input, output, session){
    ns <- session$ns

    # Color coding
    colorCoding <- reactive({

      tagList(
        tags$b("Legend"),
        tags$p(drawBullet(color = paste(myColors[1], "; border: 1px solid black")), "Adjusted p Value > 0.05"),
        tags$p(drawBullet(color = myColors[2]), "0.01 < Adjusted p Value", HTML("&le;"), "0.05"),
        tags$p(drawBullet(color = myColors[3]), "0.001 < Adjusted p Value", HTML("&le;"), "0.01"),
        tags$p(drawBullet(color = myColors[4]), "0.0001 < Adjusted p Value", HTML("&le;"), "0.001"),
        tags$p(drawBullet(color = myColors[5]), "Adjusted p Value", HTML("&le;"), "0.0001")

      )

    })

    output$info_colorCoding <- renderUI(colorCoding())


    # Example Data
    output$info_exampleData <- downloadHandler(
      filename = "exampleData.zip",
      content = function(file)  {
        dataDir <- system.file("extdata/exampleData", package = "astraGrowthRateExplorer")

        oldDir <- getwd()
        setwd(dataDir)
        on.exit(setwd(oldDir))

        zip(zipfile = file, files =  list.files(dataDir))
      }
    )


    # Pipeline: Make this graph once
    if (FALSE) {

      library("diagram")

      png(file = file.path(system.file("app/www", package = "astraGrowthRateExplorer"), "diagram.png"),
          width = 1500, height = 200)
      par(mar = c(0, 0.5, 0, 0.5))
      plot.new()

      boxColor <- "blue"

      elpos <- coordinates(5)

      fromto <- matrix(ncol = 2, byrow = TRUE,
                       data = c(1, 2, 2, 3, 3, 4, 4, 5))

      nr <- nrow(fromto)
      arrpos <- matrix(ncol = 2, nrow = nr)
      for (i in 1:nr)
        arrpos[i,] <- straightarrow(to = elpos[fromto[i,2],], from = elpos[fromto[i,1],],
                                    lwd = 2, arr.pos = 0.6, arr.length = 0.5, lcol = boxColor)

      voi <- list(
        "Input Data",
        c("Data Quality Control"),
        c("Calculate Growth Rate", "Summary Metric"),
        c("Statistical Analysis of", "Growth Rate"),
        "Report Generation"
      )
      for (iVar in 1:5)
        textrect(elpos[iVar,], radx = 0.08, rady = 0.15,
                 lab = voi[[iVar]], lcol = boxColor, cex = 1.2, lwd = 1.5)

      dev.off()

    }


  })
}

## To be copied in the UI
# mod_info_app_ui("info_app_1")

## To be copied in the server
# mod_info_app_server("info_app_1")

Here is load_data_app:

#' mod_load_app_ui UI Function
#'
#' @description A shiny Module.
#'
#' @param id,input,output,session Internal parameters for {shiny}.
#'
#' @noRd
#'
#' @importFrom shiny NS tagList
mod_load_app_ui <- function(id, label = "Load Data") {
  ns <- NS(id)
  tagList(
    shiny::tabPanel(
    title = "Load Data",
    icon = icon("fa-light fa-database"),
    label = label,

      tags$br(),

      shiny::sidebarLayout(
        shiny::sidebarPanel(
          hidden(
            actionButton(
              inputId = "load_loadNewButton",
              icon = icon("arrow-alt-circle-up"),
              label = "Upload new data"
            )
          ),
          # Load data
          div(
            id = "load_inputDataSpecifics",
            fileInput(
              inputId = "load_file",
              label = "Data File(s)",
              accept = c(".csv", ".xlsx"),
              multiple = TRUE
            ),
            uiOutput("load_selectColumnNamesUI"),
            uiOutput("load_dayOffsetInput"),
            uiOutput("load_loadDataButtonUI")

          ),
          uiOutput("load_warnings"),

          hidden(
            div(
              id = "load_hiddenOnLoad",

              # Warning if duplicate variable names
              tags$h4("Study Levels"),
              uiOutput("load_studyLevels"),

              # Treatment levels
              tags$h4("Treatment Levels"),
              uiOutput("load_trtLevels"),

              # Sample Quality Control
              shiny::uiOutput("load_sampleQC"),
              shiny::tabsetPanel(
                id = "load_sampleQCTables",
                shiny::tabPanel(
                  title = "settings",
                  renderTable(
                    astraGrowthRateExplorer::QCsettingsOutput(results$load_QCsettings),
                    na = "",
                    width = "100%",
                    caption = "Current settings"
                  )
                ),
                shiny::tabPanel(
                  title = "excluded",
                  renderTable(
                    results$load_excludedByQC,
                    na = "",
                    width = "100%",
                    caption = "Summary of excluded data points"
                  )
                )
              ),

              #            uiOutput("load_nExcludedSamples"),
              #            tableOutput("load_excludedSamples"),

              tags$h4("Exclude Outliers"),
              div(
                id = "load_exclude",
                shiny::radioButtons(
                  inputId = "load_outlierType",
                  label = "Outlier data for",
                  choices = c(
                    "Animal" = 1,
                    "Day" = 2 ,
                    "Animal at specific day" = 3
                  ),
                  inline = TRUE
                ),
                shiny::selectInput(
                  inputId = "load_excludeIdSelect",
                  label = "Select animal_id",
                  choices = c()
                ),
                shiny::selectInput(
                  inputId = "load_excludeDaySelect",
                  label = "Select day",
                  choices = c()
                ),

                shiny::textInput(
                  inputId = "load_excludeReason",
                  label = NULL,
                  placeholder = "please provide a reason here"
                ),
                shiny::uiOutput("load_excludeButtonUI")

              ),
              # Excluded outliers
              shiny::uiOutput("load_outliers")
            )
          )
        ),

        shiny::mainPanel(
          tags$h3("Loaded Data"),

          shiny::uiOutput("load_missingValues"),

          shiny::tabsetPanel(
            id = "load_dataTabs",
            shiny::tabPanel(
              title = "Raw",
              value = "load_dataRawPanel",
              DT::DTOutput("load_dataRaw")
            ),
            shiny::tabPanel(
              title = "Volume",
              value = "load_dataVolumePanel",
              DT::DTOutput("load_dataVolume"),
              shiny::fluidRow(column(
                4,
                shiny::uiOutput("load_plotVolumeStudy")
              ),
              column(
                4,
                shiny::uiOutput("load_plotVolumeTreatments")
              )),
              shiny::actionButton("load_refresh_volume", label = icon("sync-alt")),
              tags$div(style = "margin-bottom:50px",
                       plotlyOutput("load_plotVolume", height = "500px")),
              shiny::fluidRow(column(
                4,
                uiOutput("load_plotlyVolumeLogTreatments")
              ),
              column(
                4,
                uiOutput("load_plotlyVolumeLogIds")
              )),
              shiny::actionButton("load_refresh_volumeLogId", label = icon("sync-alt")),
              tags$div(
                style = "margin-bottom:50px",
                plotlyOutput("load_plotVolumeLogId", height = "500px")
              )
            ),
            shiny::tabPanel(
              title = "GR",
              value = "load_dataPanel",
              # Table
              DT::DTOutput("load_data"),

              # Plot
              shiny::uiOutput("load_selectedRowGR"),
              shiny::uiOutput("load_showPlot"),
              shiny::selectInput(
                inputId = "load_MBPlotFacet",
                label = "group by",
                choices = c("Study" = "study", "Treatment" = "treatment")
              ),
              shiny::actionButton("load_refresh_GR", label = icon("sync-alt")),
              tags$div(style = "margin-bottom:50px",
                       plotlyOutput("load_plotlyGR", height = "600px"))
            )
          )
        )
      )
    ))



    # )



}

#' mod_load_app_server Server Functions
#'
#' @noRd
mod_load_app_server <- function(id) {

  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    observe({
      req(results$load_dataType())

      if (length(input$load_loadDataButton) == 1) {
        toggleElement(id = "load_MBPlotFacet",
                      condition = results$load_dataType() == 2)
      }

      toggleElement(id = "load_excludeIdSelect",
                    condition = input$load_outlierType %in% c(1, 3))
      toggleElement(id = "load_excludeButton",
                    condition = isTruthy(input$load_excludeReason))
      toggleElement(id = "load_excludeDaySelect",
                    condition = input$load_outlierType %in% c(2, 3))

    })

    observe({
      req(results$load_dataVolume())
      updateSelectInput(session,
                        inputId = "load_excludeDaySelect",
                        choices = sort(unique(results$load_dataVolume()$day)))

      sortedIds <- list()
      for (treatment in levels(results$load_dataVolume()$treatment)) {
        ids <-
          unique(results$load_dataVolume()$animal_id[results$load_dataVolume()$treatment == treatment])
        sortedIds[[treatment]] <- ids
      }

      updateSelectInput(session, inputId = "load_excludeIdSelect", choices = sortedIds)
    })

    output$load_selectColumnNamesUI <- renderUI({
      req(results$load_dataInputFile0())

      myColumns <- matchColumns(results$load_dataInputFile0())
      names <- names(myColumns)
      inputIds <- paste0("load_columnName_", names)

      tagList(
        textInput("load_dayOffset",
                  label = "Specify how day is defined",
                  value = "Post-implant"),
        helpText(
          "Please check whether the program has detected the right columns"
        ),
        lapply(1:length(myColumns), function(i)
          selectizeInput(
            inputId = inputIds[i],
            label = names[i],
            choices = myColumns[[i]]$options,
            selected = myColumns[[i]]$guess
          ))
      )
    })


    output$load_dayOffsetInput <- renderUI({
      req(results$load_dataInputFile0())
      req(input$load_columnName_day)
      dayColumn <-
        results$load_dataInputFile0()[, input$load_columnName_day]
      if (isDate(dayColumn)) {
        minDate <- min(as.Date(dayColumn), na.rm = TRUE)
        dateInput("load_dayDateOffset",
                  label = "Specify start date",
                  value = minDate)
      }
      else
        NULL
    })

    output$load_excludeButtonUI <- renderUI({
      validate(need(
        !grepl("QC_", input$load_excludeReason),
        "Please provide a reason without 'QC_'"
      ))
      actionButton(inputId =  "load_excludeButton",
                   label = "Exclude",
                   icon = icon("trash"))
    })


    # make resetting button when data specifications change
    output$load_loadDataButtonUI <- renderUI({
      req(results$load_dataInputFile0())
      input$load_loadNewButton             # rerender on when new data will be specified
      if (length(results$load_validDataErrors()) == 0)
        actionButton(inputId = "load_loadDataButton",
                     label = "Calculate growth rate",
                     icon = icon("random"))
      else
        tagList(
          warningStyle("The app is not able to analyze your data."),
          lapply(results$load_validDataErrors(), function(x) {
            text <- sprintf("ERROR: %s", x)
            warningStyle(text)
          })
        )
    })

    # start the actual transformering and loading of the data. Moreover, hide data input fields.
    observeEvent(input$load_loadDataButton, {
      req(results$load_dataInputFile0())
      updateTabsetPanel(session = session,
                        inputId = "load_dataTabs",
                        selected = "load_dataVolumePanel")
      hide("load_inputDataSpecifics")
      show("load_loadNewButton")
      show("load_hiddenOnLoad")
      click("load_applyQC")
    })

    observeEvent(input$load_loadNewButton, {
      updateTabsetPanel(session = session,
                        inputId = "load_dataTabs",
                        selected = "load_dataRawPanel")
      results$load_exludedOutliers <- NULL
      results$load_QCsettings <- NULL
      show("load_inputDataSpecifics")
      hide("load_hiddenOnLoad")
      hide("load_loadNewButton")
    })

    # Sample quality control
    output$load_sampleQC <- renderUI({
      req(results$load_dataVolumeRaw())
      df <- results$load_dataVolumeRaw()

      t <- table(df$animal_id)
      maxDay <- max(df$day, na.rm = TRUE)
      minDay <- min(df$day, na.rm = TRUE)
      guessedUnit <-
        if (median(df$tumourVolume, na.rm = TRUE) < 2)
          1000
      else
        1

      tagList(
        tags$h4("Sample Quality Control"),
        sliderInput(
          inputId = "load_days",
          label = "Days to include",
          min = minDay,
          max = maxDay,
          value = c(NA, NA),
          step = 1
        ),
        sliderInput(
          "load_minNo",
          label = "Select minimal # of measurements per animal",
          value = 3,
          min = 3,
          max = max(t) - 1
        ),
        textOutput("load_minOutliers"),
        radioButtons(
          inputId = "load_volumeScalingFactor",
          label = "Loaded data volume unit",
          selected = guessedUnit,
          choices = c("mm3" = 1, "cm3" = 1000)
        ),
        actionButton(
          inputId = "load_applyQC",
          label = "Apply QC settings",
          icon = icon("cog")
        )
      )
    })

    # Choose treatment levels
    output$load_trtLevels <- renderUI({
      initLevels <-
        getTreatmentLevels(data = results$load_dataVolumeRaw())
      choices <- unlist(initLevels)
      names(choices) <- NULL

      tagList(
        # Ref
        selectInput(
          inputId = "load_refTrt",
          label = "Reference",
          choices = choices,
          selected = initLevels$ref
        ),

        selectizeInput(
          inputId = "load_otherTrt",
          label = "Treatment(s)",
          choices = initLevels$trt,
          selected = initLevels$trt,
          multiple = TRUE,
          options = list(plugins = list('drag_drop'))
        ),
        helpText(
          "The order of the treatments in all tables/plots can be changed by dragging the levels"
        )
      )
    })

    # Exclude reference for treatment levels
    observe({
      allChoices <-
        unlist(getTreatmentLevels(data = results$load_dataVolumeRaw()))
      trtChoices <-
        allChoices[-which(allChoices == input$load_refTrt)]
      names(trtChoices) <- NULL
      updateSelectInput(session,
                        "load_otherTrt",
                        choices = trtChoices,
                        selected = trtChoices)
    })


    # Selected treatment levels
    results$load_trtLevels <- reactive({
      req(input$load_refTrt)
      req(input$load_otherTrt)
      list(ref = input$load_refTrt,
           trt = {
             if (input$load_refTrt %in% input$load_otherTrt)
               input$load_otherTrt[-which(input$load_otherTrt == input$load_refTrt)]
             else
               input$load_otherTrt
           })
    })

    # Choose study levels
    output$load_studyLevels <- renderUI({
      initLevels <- levels(results$load_dataVolumeRaw()$study)
      choices <- unlist(initLevels)
      names(choices) <- NULL

      tagList(
        selectizeInput(
          inputId = "load_studyLevels",
          label = "Studies",
          choices = choices,
          selected = choices,
          multiple = TRUE,
          options = list(plugins = list('drag_drop'))
        ),
        helpText(
          "The order of the studies in all tables/plots can be changed by dragging the levels"
        )
      )
    })


    ## ----- ##
    ## Input ##
    ## ----- ##

    results$load_dataType <-
      reactive({
        # Single study or multiple? -> important for shown analysis
        req(input$load_studyLevels)
        if (length(input$load_studyLevels) > 1)
          t <- 2
        else
          t <- 1
        t
      })

    # data exactly as read by the file
    results$load_dataInputFile0 <- reactive ({
      validate(need(input$load_file, "Please load data"))
      tryCatch({
        files <- input$load_file$datapath
        names(files) <- input$load_file$name
        output <- loadData(file = files)
      },
      error = function(e)
        validate(
          need(
            FALSE,
            "Data could not be loaded. Please check whether you selected the correct 'Data Type'"
          )
        ))
      output
    })

    # data exactly as read by the file (but only load once start anaylsis is pressed)
    results$load_dataInputFile <- reactive({
      req(results$load_dataInputFile0())
      validate(need(
        input$load_loadDataButton == 1,
        "Please start the analysis first."
      ))
      results$load_dataInputFile0()
    })

    # raw volume data for single batch
    results$load_dataVolumeRaw <- reactive({
      df <- results$load_dataInputFile()

      # remove columns without decent header
      df <- df[, sapply(colnames(df), isTruthy)]

      df <- transformSB(
        df,
        wide = FALSE,
        group = input$load_columnName_group,
        treatment = input$load_columnName_treatment,
        animal_id = input$load_columnName_animal_id,
        tumourVolume = input$load_columnName_tumourVolume,
        day = input$load_columnName_day,
        study = input$load_columnName_study,
        dayOffset = input$load_dayDateOffset
      )
      df <- df[!is.na(df$tumourVolume), ]
    })

    results$load_selectedCols <- reactive({
      req(results$load_dataInputFile0())
      req(input$load_columnName_animal_id)
      req(input$load_columnName_group)
      req(input$load_columnName_treatment)
      req(input$load_columnName_study)
      req(input$load_columnName_tumourVolume)
      req(input$load_columnName_day)
      list(
        "animal_id" = input$load_columnName_animal_id,
        "group" = input$load_columnName_group,
        "treatment" = input$load_columnName_treatment,
        "study" = input$load_columnName_study,
        "tumourVolume" = input$load_columnName_tumourVolume,
        "day" = input$load_columnName_day
      )
    })

    results$load_validDataErrors <- reactive({
      req(results$load_selectedCols())
      selectedCols <- results$load_selectedCols()

      validId <-
        isValidIdColumn(results$load_dataInputFile0()[, selectedCols$animal_id])
      validGroup <-
        isValidGroupColumn(results$load_dataInputFile0()[, selectedCols$group])
      validTreatment <-
        isValidTreatmentColumn(results$load_dataInputFile0()[, selectedCols$treatment])
      validStudy <-
        isValidStudyColumn(results$load_dataInputFile0()[, selectedCols$study])
      validTumourVolume <-
        isValidTumourVolumeColumn(results$load_dataInputFile0()[, selectedCols$tumourVolume])
      validDay <-
        isValidDayColumn(results$load_dataInputFile0()[, selectedCols$day])

      errors <- list(
        if (length(unique(selectedCols)) != length(selectedCols))
          "Must select a different variable for each essential column.",
        if (validId != TRUE)
          validId,
        if (validGroup != TRUE)
          validGroup,
        if (validTreatment != TRUE)
          validTreatment,
        if (validStudy != TRUE)
          validStudy,
        if (validTumourVolume != TRUE)
          validTumourVolume,
        if (validDay != TRUE)
          validDay
      ) %>% unlist
      errors
    })

    # Warnings from loading the data
    results$load_warnings <- reactive({
      req(results$load_dataInputFile0())

      # duplicate variable names
      duplicateNames <-
        attr(results$load_dataInputFile0(), "duplicateNames")

      # excluded count variables
      excludedCount <-
        attr(results$load_dataInputFile0(), "excludedVariables")



      # other warnings
      warning <- attr(results$load_dataInputFile0(), "warning")

      tagList(
        if (!is.null(duplicateNames))
          warningStyle(text = "WARNING: Following duplicated variable names in loaded data are given unique name"),
        tags$ul(lapply(duplicateNames, tags$li)),

        if (!is.null(warning))
          warningStyle(paste("WARNING:", warning))
      )
    })

    output$load_warnings <- renderUI(results$load_warnings())

    # Volume data after QC
    results$load_dataVolume <- reactive({
      req(results$load_dataVolumeRaw())
      req(results$load_trtLevels())
      req(results$load_QCsettings)

      data <- results$load_dataVolumeRaw()

      # exclude outliers
      toExclude <- which(results$load_exludedOutliers != FALSE)
      if (length(toExclude) > 0)
        data <- data[-toExclude, ]

      # apply QC settings
      process <- processData(df = data,
                             settings = results$load_QCsettings)
      data <- process$df
      results$load_excludedByQC <- process$ex

      # keep track of the rows excluded by QC
      exQC <- rep(FALSE, nrow(results$load_dataVolumeRaw()))
      rowNames <- rownames(results$load_dataVolumeRaw())
      indices <- which(rowNames %in% process$name$name)
      for (i in indices) {
        name <- rowNames[i]
        reason <-
          as.character(process$name$reason[process$name$name == name])
        exQC[i] <-  paste0("QC_", reason)
      }
      results$load_exludedQC <- exQC

      # set order of data
      data <- assignStudyLevels(data, input$load_studyLevels)
      data <- assignTreatmentLevels(data, results$load_trtLevels())
      data <- data[order(data$study, data$treatment), ]

      data
    })

    results$load_exludedRows <- reactive({
      ex1 <- results$load_exludedOutliers
      ex2 <- results$load_exludedQC

      if (length(ex1) == 0)
        ex1 <- FALSE
      if (length(ex2) == 0)
        ex2 <- FALSE
      ex <- cbind(ex1, ex2)
      apply(ex, 1, function(x) {
        # first check if outlier is reason of exclusion, if not find QC reason
        if (x[1] != FALSE)
          x[1]
        else
          x[2]
      })
    })

    results$load_outliers <- reactive({
      req(results$load_dataVolumeRaw())
      req(results$load_exludedRows)
      summarizeExclusions(results$load_dataVolumeRaw(),
                          results$load_exludedRows())
    })

    # Growth rate data
    results$load_data <- reactive({
      req(results$load_dataVolume())
      validate(need((nrow(
        results$load_dataVolume()
      ) > 0),
      "Need more data to calculate growthrates."))
      regressionOutput(results$load_dataVolume())
    })


    # Quality control settings
    results$load_QCsettings <- NULL
    observeEvent(input$load_applyQC,
                 ignoreInit = FALSE,
                 ignoreNULL = FALSE,
                 {
                   if (is.null(results$load_QCsettings)) {
                     settings <- data.frame(
                       study = levels(results$load_dataVolumeRaw()$study),
                       startDay = input$load_days[1],
                       endDay = input$load_days[2],
                       minNo = input$load_minNo,
                       volumeScalingFactor = as.numeric(input$load_volumeScalingFactor)
                     )
                   }
                   else{
                     settings <- results$load_QCsettings
                     settings[settings$study %in% input$load_studyLevels, ] <-
                       data.frame(
                         study = input$load_studyLevels,
                         startDay = input$load_days[1],
                         endDay = input$load_days[2],
                         minNo = input$load_minNo,
                         volumeScalingFactor = as.numeric(input$load_volumeScalingFactor)
                       )
                   }
                   results$load_QCsettings <- settings
                 })


    #' get rows that would be excluded from a data.frame
    #' @param data.frame data.frame
    #' @param values named list (possibly of lists)
    #' @importFrom plyr match_df
    excludedOutliers <- function(df, values) {
      values <- expand.grid(values)     # unlist list of values
      myData <- df[, colnames(values)]
      which(rownames(df) %in% rownames(plyr::match_df(myData, values)))
    }


    # Button for excluding outlier
    output$load_outlierButton <- renderUI({
      validate(need(input$load_outlierReason, "Please provide a reason"))
      validate(need(
        !grepl("QC_", input$load_outlierReason),
        "Please provide a reason without 'QC_'"
      ))

      actionButton(inputId = "load_excludeOutlier",
                   label = "Exclude Outlier",
                   icon = icon("trash"))
    })

    observe({
      results$load_exludedOutliers <-
        rep(FALSE, nrow(results$load_dataVolumeRaw()))
    })

    # Add selected plot outlier to the list
    observeEvent(input$load_excludeOutlier, {
      # update exclusion list
      values <- list(
        "animal_id" = results$load_selectedRowGR()$animal_id,
        "study" =  results$load_selectedRowGR()$study
      )
      exIndices <-
        excludedOutliers(results$load_dataVolumeRaw(), values)
      newEx <- results$load_exludedOutliers
      newEx[exIndices] <- input$load_outlierReason
      results$load_exludedOutliers <- newEx
    })

    # Add outlier to the list
    observeEvent(input$load_excludeButton, {
      req(input$load_excludeButton)

      values <- list("study" = input$load_studyLevels)
      if (input$load_outlierType %in% c(2, 3))
        values$day <- as.integer(input$load_excludeDaySelect)

      if (input$load_outlierType %in% c(1, 3)) {
        values$animal_id <- input$load_excludeIdSelect
        values$treatment <- results$load_dataVolumeRaw()$treatment[{
          results$load_dataVolumeRaw()$animal_id == values$animal_id &
            results$load_dataVolumeRaw()$study == values$study
        }][1]
      }

      # update exclusion list
      exIndices <-
        excludedOutliers(results$load_dataVolumeRaw(), values)
      newEx <- results$load_exludedOutliers
      newEx[exIndices] <-  input$load_excludeReason
      results$load_exludedOutliers <- newEx
    })


    # Selected point in the graph
    observe({
      req(results$load_plotlyGR())                                 # prevent warning on startup
      results$GRplotRegistered <- TRUE
    })

    observe({
      req(results$GRplotRegistered)
      results$load_selectedRownGR <-
        event_data("plotly_click", source = "GRplot")$key
    })

    observe({
      results$load_data()
      results$load_selectedRownGR <-  NULL
    })

    results$load_selectedRowGR <- reactive({
      if (isTruthy(results$load_selectedRownGR)) {
        GR_data <- isolate(results$load_data())
        GR_data[results$load_selectedRownGR , ]
      }
      else
        NULL
    })

    ### ------ ##
    ### Output ##
    ### ------ ##



    # Warning for missing values in data
    output$load_missingValues <- renderUI({
      req(results$load_dataInputFile0())

      if (any(is.na(results$load_dataInputFile0())))
        warningStyle("WARNING: Some values are missing for the loaded data. They are highlighted in red.")

    })

    # Table with raw data
    output$load_dataRaw <- DT::renderDT({
      req(results$load_dataInputFile0())
      myData <- results$load_dataInputFile0()

      myTable <-
        DT::datatable(
          results$load_dataInputFile0(),
          rownames = FALSE,
          selection = "none",
          filter = list(position = 'top', clear = FALSE),
          options = list(dom = 'tip')
        )

      # Highlight missing value
      if (any(is.na(myData)))
        myTable <-
        myTable %>% DT::formatStyle(
          columns = 1:ncol(myData),
          target = "cell",
          backgroundColor = DT::styleEqual(NA, "#e52323")
        )

      myTable
    })

    # Table with loaded data
    output$load_data <- DT::renderDT({
      req(results$load_data())
      myData <- results$load_data()
      myTable <- DT::datatable(
        myData,
        #          rownames = FALSE,
        selection = "none",
        filter = list(position = 'top', clear = FALSE),
        options = list(
          dom = 'tip',
          displayStart = {
            if (!is.null(results$load_selectedRowGR()))
              (which(
                rownames(myData) == rownames(results$load_selectedRowGR())
              ) - 1) %/% 10 * 10
            else
              0
          },
          columnDefs = list(list(
            targets = 0, visible = FALSE
          )) # hide row names
        )
      )

      # Highlight missing value
      if (any(is.na(myData)))
        myTable <-
        myTable %>% DT::formatStyle(
          columns = 1:ncol(myData),
          target = "cell",
          backgroundColor = DT::styleEqual(NA, "#e52323")
        )

      if (!is.null(results$load_selectedRowGR()))
        myTable <- myTable %>%
        DT::formatStyle(
          0,
          target = "row",
          backgroundColor = DT::styleEqual(results$load_selectedRownGR, "#32a6d3")
        )
      myTable <-
        myTable %>% DT::formatRound(columns = 4:ncol(myData), digits = 4)

    })


    # Table with loaded dataVolume
    output$load_dataVolume <- DT::renderDT({
      req(results$load_dataVolume())

      myData <-
        results$load_dataVolume()[, names(getCriticalColumns())]
      myData[, "group"] <- NULL # do not display group

      myTable <-
        DT::datatable(
          myData,
          rownames = FALSE,
          selection = "none",
          filter = list(position = 'top', clear = FALSE),
          options = list(dom = 'tip')
        )

      # Highlight missing value
      if (any(is.na(myData)))
        myTable <-
        myTable %>% DT::formatStyle(
          columns = 1:ncol(myData),
          target = "cell",
          backgroundColor = DT::styleEqual(NA, "#e52323")
        )

      #      if (!is.null(results$load_selectedKey()))
      #        myTable <- myTable %>%
      #            DT::formatStyle(columns = "animal_id", target = "row",
      #                backgroundColor = DT::styleEqual(results$load_selectedKey(), "#32a6d3")
      #            )
      myTable <- myTable %>%
        DT::formatRound(columns = "tumourVolume", digits = 4) %>%
        DT::formatRound(columns = "day", digits = 0)
    })

    # Selected animal_id in plot
    output$load_selectedRowGR <- renderUI({
      req(results$load_outliers)
      # Update when point is excluded
      nrow(results$load_outliers())

      tagList(
        helpText(
          "By clicking on a point in the plot, the corresponding row will be highlighted in blue in the table"
        ),
        if (!is.null(results$load_selectedRowGR()))
          wellPanel(
            warningStyle("Do you want to exclude the highlighted sample from the data?"),
            p(
              tags$b("Selected Sample:"),
              results$load_selectedRowGR()$animal_id
            ),
            p(tags$b("Study:"), results$load_selectedRowGR()$study),
            tags$b("Reason"),
            fluidRow(column(
              10,
              textInput(
                inputId = "load_outlierReason",
                label = NULL,
                width = "100%"
              )
            ),
            column(2, uiOutput(
              "load_outlierButton"
            )))
          )
      )
    })




    # List excluded outliers
    output$load_outliers <- renderUI({
      req(results$load_exludedRows)
      validate(need(
        results$load_exludedRows(),
        "No outliers have been excluded."
      ))
      nOutliers <- sum(results$load_exludedRows() != FALSE)
      tagList(
        warningStyle(
          paste(
            "WARNING: There",
            if (nOutliers == 1)
              paste("was", nOutliers, "data point")
            else
              paste("were", nOutliers, "data points"),
            "excluded"
          )
        ),
        renderTable(
          results$load_outliers(),
          na = "",
          width = "100%",
          caption = "Summary of excluded data points"
        ),
        actionButton("load_outlierSummaryHelp", "?")
      )
    })

    observeEvent(input$load_outlierSummaryHelp, {
      showModal({
        modalDialog(
          title = "Outlier summary explanation",
          p("Blank cells should be read as 'all'."),
          renderTable(
            na = "",
            width = "100%",
            data.frame(
              animal_id = "",
              treatment = "",
              study = "myStudy",
              day = "9",
              reason = "QC_day",
              N = "5"
            )
          ),
          p(
            "\"All animals and all treatments for study 'myStudy' have been excluded at day 9 because of 'day quality control'.\""
          ),
          p("A total of 5 data points have been exluded because of this."),
          footer = modalButton("dismiss")
        )
      })
    })

    # PLOTS

    # plot display control

    output$load_plotVolumeStudy <- renderUI({
      selectInput(
        inputId = "load_plotVolumeStudy",
        label = "choose study",
        choices = input$load_studyLevels
      )
    })

    output$load_plotVolumeTreatments <- renderUI({
      treatments <- unique(
        subset(
          results$load_dataVolume(),
          subset = study == input$load_plotVolumeStudy
        )$treatment
      )
      startN <- min(5, length(treatments))

      selectInput(
        inputId = "load_plotVolumeTreatments",
        label = "choose treatments",
        choices = treatments,
        selected = treatments[1:startN],
        multiple = TRUE
      )
    })

    output$load_plotlyVolumeLogTreatments <- renderUI({
      req(results$load_trtLevels())
      choices <- results$load_trtLevels()

      # give appropriate names for display
      names(choices)[1] <- choices$ref
      if (length(choices$trt) == 1)
        names(choices)[2] <- choices$trt
      else
        names(choices)[2] <- "treatments"

      selectInput(inputId = "load_plotlyVolumeLogTreatment",
                  label = "choose treatment",
                  choices = choices)
    })

    output$load_plotlyVolumeLogIds <- renderUI({
      ids <- unique(
        subset(
          results$load_dataVolume(),
          subset =
            treatment == input$load_plotlyVolumeLogTreatment &
            study == input$load_plotVolumeStudy
        )$animal_id
      )
      startN <- min(10, length(ids))

      selectInput(
        inputId = "load_plotlyVolumeLogIds",
        label = "choose animal_id",
        choices = ids,
        selected = ids[1:startN],
        multiple = TRUE
      )
    })


    # plots

    output$load_plotVolume <- renderPlotly({
      req(results$load_dataVolume())
      req(input$load_plotVolumeTreatments)
      input$load_refresh_volume

      validate(need(
        !any(duplicated(unlist(
          results$load_trtLevels()
        ))),
        "Please choose Treatment(s) different from the reference"
      ))
      myData  <- subset(
        results$load_dataVolume(),
        study == input$load_plotVolumeStudy &
          treatment %in% input$load_plotVolumeTreatments
      )
      if (nrow(myData) > 0) {
        p <- plotlyVolume(myData)
      }
      else
        p <- NULL
      p
    })

    output$load_plotVolumeLogId <- renderPlotly({
      req(results$load_dataVolume())
      req(input$load_plotlyVolumeLogTreatment)
      input$load_refresh_volumeLogId

      validate(need(
        !any(duplicated(unlist(
          results$load_trtLevels()
        ))),
        "Please choose Treatment(s) different from the reference"
      ))

      myData <- subset(
        results$load_dataVolume(),
        treatment == input$load_plotlyVolumeLogTreatment &
          animal_id %in% input$load_plotlyVolumeLogIds &
          study == input$load_plotVolumeStudy
      )

      if (nrow(myData) > 0)
        plot <- plotlyVolumeLogId(df = myData)
      else
        plot <- NULL
      plot
    })

    results$load_plotGR <- reactive({
      req(results$load_data())
      req(input$load_MBPlotFacet)

      if (input$load_MBPlotFacet == "treatment") {
        xVar <- "study"
      } else{
        xVar <- "treatment"
      }

      suppressWarnings(
        plotGrowthRate(
          df = results$load_data(),
          xVar = xVar,
          facetVar = input$load_MBPlotFacet,
          withJitter = TRUE
        )
      )
    })

    results$load_plotlyGR <- reactive({
      req(results$load_data())
      req(input$load_MBPlotFacet)

      if (input$load_MBPlotFacet == "treatment") {
        xVar <- "study"
      } else{
        xVar <- "treatment"
      }

      suppressWarnings(
        plotlyGrowthRate(
          df = results$load_data(),
          xVar = xVar,
          facetVar = input$load_MBPlotFacet,
          withJitter = TRUE,
          selected = rownames(results$load_selectedRowGR()),
          source = "GRplot"
        )
      )
    })

    output$load_plotlyGR <- renderPlotly({
      input$load_refresh_GR
      results$load_plotlyGR()
    })


  })
}

## To be copied in the UI
# mod_load_app_ui("load_app_1")

## To be copied in the server
# mod_load_app_server("load_app_1")

If you want to see the user interface, as to how Info tab with Load Data tab get mixed up, check the stackoverflow link where I've posted a pic:

https://stackoverflow.com/questions/75453946/why-i-do-not-get-my-data-under-the-load-data-panel

@gabrielburcea
Copy link
Author

Hello peps. Would you please help? I have opened up a bounty on stackoverlow! Wish someone can help. I can also make available the github repo for the person who's willing to help!

@gabrielburcea
Copy link
Author

@ColinFay I beg for help! Please do help . Also the bounty on stackoverflow expires. I simply beg for help.

@ArthurData
Copy link
Member

Hello @gabrielburcea,

Sorry for the long wait for a reply.
Is this problem still true? If so, I'd be delighted to help.

@ColinFay
Copy link
Member

ColinFay commented Aug 8, 2024

Closed on SO, so closing here :)

@ColinFay ColinFay closed this as completed Aug 8, 2024
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

3 participants