R/modInput.R

In nprcgenekeepr: Genetic Tools for Colony Management

## Copyright(c) 2017-2026 R. Mark Sharp
## This file is part of nprcgenekeepr

# Data Input and Quality Control Shiny Module

#' Parse an optional age textInput value into a numeric floor or NULL
#'
#' Blank, whitespace-only, \code{NA}, or non-numeric input maps to \code{NULL}
#' (meaning "use the species+sex breeding-age table default"); a valid number
#' maps to that numeric value. Used by \code{\link{modInputServer}} to turn the
#' two optional "Minimum Sire Age" / "Minimum Dam Age" fields into the
#' \code{minSireAge} / \code{minDamAge} arguments threaded to the QC callees.
#'
#' @param x a length-1 character or numeric input value, possibly \code{NULL}.
#' @return a length-1 numeric floor, or \code{NULL} when the input is blank,
#'   \code{NA}, or not a number.
#' @noRd
parseOptionalAge <- function(x) {
  if (is.null(x) || length(x) == 0L) {
    return(NULL)
  }
  x <- trimws(as.character(x))
  if (!nzchar(x) || is.na(x)) {
    return(NULL)
  }
  v <- suppressWarnings(as.numeric(x))
  if (is.na(v)) NULL else v
}

#' Data Input and Quality Control Module - UI Function
#'
#' Creates user interface for data input including file uploads for
#' pedigree and genotype data with various format options, followed by
#' quality control validation.
#'
#' @param id character vector of length 1. Module namespace identifier.
#'
#' @return A \code{div} object containing the data input UI.
#'
#' @seealso \code{\link{modInputServer}} for server logic.
#' @seealso \code{\link{modPedigreeUI}} for pedigree browsing after QC.
#' @importFrom shiny NS div h3 h4 tags fluidRow column sidebarLayout
#' @importFrom shiny sidebarPanel mainPanel helpText radioButtons
#' @importFrom shiny conditionalPanel fileInput textInput actionButton
#' @importFrom shiny checkboxInput icon includeHTML br hr tabsetPanel tabPanel
#' @importFrom shiny uiOutput downloadButton updateTabsetPanel observeEvent
#' @importFrom DT DTOutput
#' @importFrom futile.logger flog.debug flog.threshold DEBUG INFO
#' @family Shiny modules
#' @export
modInputUI <- function(id) {
  ns <- NS(id)

  div(
    id = ns("moduleContainer"),
    `data-ready` = "false",
    `data-module` = "input",

    # Custom CSS for tables in the HTML documentation
    tags$style(
      type = "text/css", # nolint: nonportable_path_linter
      "table {border: 1px solid black; width: 100%; padding: 15px;}",
      "tr, td, th {border: 1px solid black; padding: 5px;}",
      "th {font-weight: bold; background-color: #7CFC00;}",
      "hr {border-width:2px;border-color:#A9A9A9;}"
    ),

    h3("Data Input and Quality Control"),

    sidebarLayout(
      sidebarPanel(
        style = paste(
          "padding: 10px; border: 1px solid lightgray;",
          "background-color: #EDEDED; border-radius: 25px;",
          "box-shadow: 0 0 5px 2px #888;"
        ),

        helpText("Select how you are submitting data."),

        # File type selection
        radioButtons(
          ns("fileType"),
          label = "File Type",
          choices = list(Excel = "fileTypeExcel", Text = "fileTypeText"),
          selected = "fileTypeExcel"
        ),

        # File content selection
        radioButtons(
          ns("fileContent"),
          label = "File Content",
          choices = list(
            "Pedigree(s) file only; genotypes not provided" = "pedFile",
            "Pedigree(s) and genotypes in one file" = "commonPedGenoFile",
            "Pedigree(s) and genotypes in separate files" =
              "separatePedGenoFile",
            "Focal animals only; pedigree built from database" = "focalAnimals"
          ),
          selected = "pedFile"
        ),

        # Separator selection for text files
        conditionalPanel(
          condition = "input.fileType == 'fileTypeText'",
          ns = ns,
          radioButtons(
            ns("separator"),
            label = "Separator",
            choices = list(Comma = ",", Semicolon = ";", Tab = "\t"),
            selected = ","
          )
        ),

        # File inputs based on content type
        conditionalPanel(
          condition = "input.fileContent == 'pedFile'",
          ns = ns,
          fileInput(ns("pedigreeFileOne"), label = "Select Pedigree File",
                    accept = c(".csv", ".txt", ".xlsx", ".xls"))
        ),

        conditionalPanel(
          condition = "input.fileContent == 'commonPedGenoFile'",
          ns = ns,
          fileInput(ns("pedigreeFileTwo"),
                    label = "Select Pedigree-Genotype File",
                    accept = c(".csv", ".txt", ".xlsx", ".xls"))
        ),

        conditionalPanel(
          condition = "input.fileContent == 'separatePedGenoFile'",
          ns = ns,
          fileInput(ns("pedigreeFileThree"), label = "Select Pedigree File",
                    accept = c(".csv", ".txt", ".xlsx", ".xls")),
          fileInput(ns("genotypeFile"), label = "Select Genotype File",
                    accept = c(".csv", ".txt", ".xlsx", ".xls"))
        ),

        conditionalPanel(
          condition = "input.fileContent == 'focalAnimals'",
          ns = ns,
          fileInput(ns("breederFile"), label = "Select Focal Animals File",
                    accept = c(".csv", ".txt", ".xlsx", ".xls")),
          fileInput(ns("focalPedigreeFile"),
                    label = paste("Optional: Pedigree File (build offline;",
                                  "no database)"),
                    accept = c(".csv", ".txt", ".xlsx", ".xls"))
        ),

        # Minimum sire and dam ages (Issue #119): two optional fields. Blank
        # means "use the species- and sex-specific breeding-age default".
        textInput(ns("minSireAge"),
                  label = "Minimum Sire Age (years)",
                  value = ""),
        textInput(ns("minDamAge"),
                  label = "Minimum Dam Age (years)",
                  value = ""),
        helpText(
          style = "font-size: 11px; color: #666;",
          paste(
            "Leave blank to use the species-specific default for each sex;",
            "enter a number to require parents be at least that old at an",
            "offspring's birth."
          )
        ),

        actionButton(ns("getData"), "Read and Check Pedigree",
                     icon = icon("upload"), class = "btn-primary btn-block"),

        checkboxInput(ns("debugger"), label = "Debug on", value = FALSE)
      ),

      # Main panel with tabs for documentation and QC results
      mainPanel(
        tabsetPanel(
          id = ns("mainTabs"),

          # Input format documentation tab
          tabPanel(
            "Input Format",
            icon = icon("info-circle"),
            br(),
            div(
              style = paste(
                "padding: 15px; border: 1px solid lightgray;",
                "background-color: #EDEDED; border-radius: 15px;",
                "box-shadow: 0 0 5px 2px #888;"
              ),
              includeHTML(
                system.file("extdata", "ui_guidance", "input_format.html",
                            package = "nprcgenekeepr")
              )
            )
          ),

          # QC Summary tab
          tabPanel(
            "QC Summary",
            icon = icon("check-circle"),
            br(),
            uiOutput(ns("qcSummaryUI"))
          ),

          # Errors tab
          tabPanel(
            "Errors",
            icon = icon("exclamation-triangle"),
            br(),
            downloadButton(ns("downloadErrors"), "Download Errors"),
            br(), br(),
            DT::DTOutput(ns("qcErrors"))
          ),

          # Warnings tab
          tabPanel(
            "Warnings",
            icon = icon("exclamation-circle"),
            br(),
            downloadButton(ns("downloadWarnings"), "Download Warnings"),
            br(), br(),
            DT::DTOutput(ns("qcWarnings"))
          ),

          # Cleaned data preview tab
          tabPanel(
            "Cleaned Data",
            icon = icon("table"),
            br(),
            downloadButton(ns("downloadCleaned"), "Download Cleaned Data"),
            br(), br(),
            DT::DTOutput(ns("cleanedDataTable"))
          )
        )
      )
    )
  )
}

#' Data Input and Quality Control Module - Server Function
#'
#' Server logic for data input module handling file uploads, parsing
#' of pedigree and genotype data files, and quality control validation.
#'
#' @param id character vector of length 1. Module namespace identifier.
#'
#' @return A list with reactive components:
#' \itemize{
#'   \item \code{cleanedStudbook} - The QC-cleaned studbook data
#'   \item \code{genotypeData} - Genotype data if provided
#'   \item \code{qcSummary} - Summary of QC results (error/warning counts)
#'   \item \code{minSireAge} - The minimum sire age floor (numeric, or
#'     \code{NULL} to use the species+sex breeding-age table default)
#'   \item \code{minDamAge} - The minimum dam age floor (numeric, or
#'     \code{NULL} to use the species+sex breeding-age table default)
#'   \item \code{isReady} - Logical indicating if data is ready for next step
#'   \item \code{debugMode} - Logical reflecting the Input tab's "Debug on"
#'     checkbox
#'   \item \code{changedCols} - Renamed/changed-column diagnostics from QC
#'   \item \code{errorLst} - The QC error list, used for dynamic tab
#'     management
#'   \item \code{pedigreeFileName} - The uploaded file's name, used for
#'     dynamic tab management
#' }
#'
#' @note (Developer note) This module is the reference implementation of the
#'   package's internal Shiny module contract -- see
#'   \code{docs/architecture/module-contract.md} in the package source (a
#'   developer-only file; it does not ship with the installed package).
#'
#' @seealso \code{\link{modInputUI}} for the user interface.
#' @seealso \code{\link{modPedigreeServer}} for using the cleaned data.
#' @importFrom shiny moduleServer reactive eventReactive req showNotification
#' @importFrom shiny renderUI withProgress incProgress
#' @importFrom DT renderDT
#' @family Shiny modules
#' @export
modInputServer <- function(id) {

  moduleServer(id, function(input, output, session) {

    # Create a reactiveVal to store QC results
    storedResults <- reactiveVal(NULL)

    # Store raw errorLst for dynamic tab display
    storedErrorLst <- reactiveVal(NULL)

    # Store the pedigree file name
    storedFileName <- reactiveVal(NULL)

    # Determine which file input to use based on content type
    activeFile <- reactive({
      switch(input$fileContent,
             pedFile = input$pedigreeFileOne,
             commonPedGenoFile = input$pedigreeFileTwo,
             separatePedGenoFile = input$pedigreeFileThree,
             focalAnimals = input$breederFile,
             NULL)
    })

    # Helper function to read file based on type
    readDataFile <- function(file, fileType, separator) {
      if (is.null(file)) return(NULL)

      tryCatch({
        fileExt <- tools::file_ext(file$name)

        futile.logger::flog.debug(
          paste0("readDataFile - fileExt: ", fileExt,
                 ", fileType: ", fileType,
                 ", separator: '", separator, "'"),
          name = "nprcgenekeepr"
        )

        if (fileExt %in% c("xlsx", "xls")) {
          futile.logger::flog.debug("Reading Excel file",
                                    name = "nprcgenekeepr")
          data <- readExcelPOSIXToCharacter(file$datapath)
        } else if (fileType == "fileTypeText") {
          futile.logger::flog.debug(
            paste0("Reading text file with separator: '", separator, "'"),
            name = "nprcgenekeepr"
          )
          data <- muffleIncompleteFinalLine(
            read.table(file$datapath, header = TRUE, sep = separator,
                       stringsAsFactors = FALSE, fill = TRUE,
                       quote = "\"")
          )
        } else {
          futile.logger::flog.debug("Reading CSV file", name = "nprcgenekeepr")
          data <- muffleIncompleteFinalLine(
            read.csv(file$datapath, stringsAsFactors = FALSE)
          )
        }

        futile.logger::flog.debug(
          paste0("File read successfully. Rows: ", nrow(data),
                 ", Cols: ", ncol(data),
                 ", Column names: ", toString(names(data))),
          name = "nprcgenekeepr"
        )

        as.data.frame(data)
      }, error = function(e) {
        futile.logger::flog.debug(
          paste0("Error reading file: ", e$message),
          name = "nprcgenekeepr"
        )
        showNotification(
          paste("Error reading file:", e$message),
          type = "error",
          duration = 10L
        )
        NULL
      })
    }

    # Process data when button is clicked
    observeEvent(input$getData, {
      # Get the active file
      file <- activeFile()

      if (is.null(file)) {
        showNotification("Please select a file first.", type = "warning")
        return()
      }

      # Store the file name for dynamic tabs
      storedFileName(file$name)

      # Read the file. The focal-animal path is special: the upload is a list
      # of focal animal IDs, not a pedigree, so build the pedigree from the
      # LabKey EHR via getFocalAnimalPed() (mirrors monolith server.r:86-113,
      # but branches on the CORRECT errorLst class -- the monolith's
      # is.element("nprckeepErr", ...) is a typo that never matched).
      sep <- if (is.null(input$separator)) "," else input$separator
      if (identical(input$fileContent, "focalAnimals")) {
        # If the user also supplied a pedigree file, build the focal animals'
        # pedigree from that FILE (offline, no database). Otherwise fall back to
        # the LabKey/EHR path. The file path fails soft to an
        # nprcgenekeeprFileErr (handled just below) that names WHY it could not
        # build the pedigree.
        pedFile <- input$focalPedigreeFile
        if (!is.null(pedFile)) {
          built <- getFocalAnimalPedFromFile(file$datapath, pedFile$datapath,
                                             sep = sep)
        } else {
          built <- getFocalAnimalPed(file$datapath, sep = sep)
        }
        if (inherits(built, "nprcgenekeeprFileErr")) {
          # Offline file path failed: surface the SPECIFIC reason (bad focal-id
          # list file; a missing/not-found/unreadable/wrong-column pedigree
          # file; or no focal IDs found) as the "File Read Error" detail,
          # instead of the generic is.null(rawData) message.
          storedResults(list(
            cleaned = NULL,
            errors = data.frame(
              Row = NA_integer_,
              Error = "File Read Error",
              Details = built$message,
              stringsAsFactors = FALSE
            ),
            warnings = data.frame(
              Row = integer(0L), Warning = character(0L),
              Details = character(0L), stringsAsFactors = FALSE
            ),
            changedCols = NULL,
            hasChangedCols = FALSE,
            genotype = NULL
          ))
          storedErrorLst(NULL)
          session$sendCustomMessage("setDataReady", list(
            selector = paste0("#", session$ns("moduleContainer")),
            ready = TRUE
          ))
          return()
        }
        if (inherits(built, "nprcgenekeeprErr")) {
          # getLkDirectRelatives returned NULL: a database connection failure.
          # Route the errorLst to storedErrorLst() so the already-wired
          # appServer dynamic Error tab surfaces failedDatabaseConnection.
          storedErrorLst(built)
          storedResults(list(
            cleaned = NULL,
            errors = data.frame(
              Row = NA_integer_,
              Error = "Database Connection Error",
              Details = built$failedDatabaseConnection,
              stringsAsFactors = FALSE
            ),
            warnings = data.frame(
              Row = integer(0L), Warning = character(0L),
              Details = character(0L), stringsAsFactors = FALSE
            ),
            changedCols = NULL,
            hasChangedCols = FALSE,
            genotype = NULL
          ))
          session$sendCustomMessage("setDataReady", list(
            selector = paste0("#", session$ns("moduleContainer")),
            ready = TRUE
          ))
          return()
        }
        rawData <- built
      } else {
        rawData <- readDataFile(file, input$fileType, input$separator)
      }

      if (is.null(rawData)) {
        storedResults(list(
          cleaned = NULL,
          errors = data.frame(
            Row = NA_integer_,
            Error = "File Read Error",
            Details = "Could not read the uploaded file.",
            stringsAsFactors = FALSE
          ),
          warnings = data.frame(
            Row = integer(0L), Warning = character(0L),
            Details = character(0L), stringsAsFactors = FALSE
          ),
          changedCols = NULL,
          hasChangedCols = FALSE
        ))
        storedErrorLst(NULL)
        return()
      }

      # Merge an uploaded genotype file (separate pedigree/genotype mode) into
      # the raw pedigree BEFORE qcStudbook, mirroring the monolith
      # (inst/application/server.r:117-156): read with getGenotypes, validate
      # with checkGenotypeFile (degrade to NULL on warning/error), then merge
      # with addGenotype so the integer first/second columns ride the cleaned
      # studbook into reportGV via getGVGenotype()/hasGenotype(). The merge is
      # guarded against a NULL genotype (addGenotype(ped, NULL) errors).
      if (identical(input$fileContent, "separatePedGenoFile") &&
            !is.null(input$genotypeFile)) {
        sep <- if (is.null(input$separator)) "," else input$separator
        genotype <- getGenotypes(input$genotypeFile$datapath, sep = sep)
        genotype <- tryCatch(
          checkGenotypeFile(genotype),
          warning = function(w) NULL,
          error = function(e) NULL
        )
        if (!is.null(genotype)) {
          rawData <- addGenotype(rawData, genotype)
        }
      }

      # Parse the optional sire/dam age floors; blank -> NULL -> the
      # species+sex breeding-age table default in the QC callees.
      sireAge <- parseOptionalAge(input$minSireAge)
      damAge <- parseOptionalAge(input$minDamAge)

      # Run QC. runQcStudbook()'s first pass already computes the raw
      # errorLst needed for dynamic tab display (XARCH-6: modInput previously
      # made its own separate qcStudbook() call to get it, duplicating this
      # same first pass) -- so it is taken from qcResult$errorLst below
      # instead of via a second qcStudbook() invocation.
      qcResult <- tryCatch({
        runQcStudbook(
          rawData,
          minSireAge = sireAge, minDamAge = damAge,
          reportChanges = TRUE
        )
      }, error = function(e) {
        list(
          cleaned = NULL,
          qcResult = list(
            errors = data.frame(
              Row = NA_integer_,
              Error = "QC Processing Error",
              Details = e$message,
              stringsAsFactors = FALSE
            ),
            warnings = data.frame(
              Row = integer(0L), Warning = character(0L),
              Details = character(0L), stringsAsFactors = FALSE
            ),
            changedCols = NULL,
            hasErrors = TRUE,
            hasChangedCols = FALSE
          )
        )
      })
      storedErrorLst(
        if (is.null(qcResult$errorLst)) getEmptyErrorLst()
        else qcResult$errorLst
      )

      # Store results in expected format. genotypeData() exposes the
      # id/first/second extract (getGVGenotype() returns NULL when the cleaned
      # studbook carries no genotype, preserving the prior contract).
      storedResults(list(
        cleaned = qcResult$cleaned,
        errors = qcResult$qcResult$errors,
        warnings = qcResult$qcResult$warnings,
        changedCols = qcResult$qcResult$changedCols,
        hasChangedCols = qcResult$qcResult$hasChangedCols,
        genotype = getGVGenotype(qcResult$cleaned)
      ))

      # Signal that QC processing is complete (for E2E testing)
      session$sendCustomMessage("setDataReady", list(
        selector = paste0("#", session$ns("moduleContainer")),
        ready = TRUE
      ))
    })

    # Keep qcResults as a simple reactive that reads storedResults
    # (for compatibility)
    qcResults <- reactive({
      storedResults()
    })

    # QC Summary UI - show results immediately after processing
    output$qcSummaryUI <- renderUI({
      tryCatch({
        futile.logger::flog.debug(
          "qcSummaryUI renderUI triggered",
          name = "nprcgenekeepr"
        )
        req(qcResults())
        results <- qcResults()

        nErrors <- nrow(results$errors)
        nWarnings <- nrow(results$warnings)
        nRecords <- if (!is.null(results$cleaned)) nrow(results$cleaned) else 0L

        futile.logger::flog.debug(
          paste0("qcSummaryUI rendering. Errors: ", nErrors,
                 ", Warnings: ", nWarnings, ", Records: ", nRecords),
          name = "nprcgenekeepr"
        )

      div(
        fluidRow(
          column(4L,
                 div(class = "panel panel-primary",
                     div(class = "panel-heading", h4("Records Processed")),
                     div(class = "panel-body", h2(nRecords)))),
          column(4L,
                 div(class = if (nErrors > 0L) {
                   "panel panel-danger"
                 } else {
                   "panel panel-success"
                 },
                     div(class = "panel-heading", h4("Errors")),
                     div(class = "panel-body", h2(nErrors)))),
          column(4L,
                 div(class = if (nWarnings > 0L) {
                   "panel panel-warning"
                 } else {
                   "panel panel-success"
                 },
                     div(class = "panel-heading", h4("Warnings")),
                     div(class = "panel-body", h2(nWarnings))))
        ),
        if (nErrors == 0L && nRecords > 0L) {
          div(
            class = "alert alert-success",
            icon("check"),
            paste0(" Data passed quality control. You may proceed to the ",
                   "Pedigree Browser.")
          )
        } else if (nErrors > 0L) {
          div(
            class = "alert alert-danger",
            icon("exclamation-triangle"),
            " Please review and fix errors before proceeding."
          )
        }
      )
      }, error = function(e) {
        futile.logger::flog.debug(
          paste0("qcSummaryUI error: ", e$message),
          name = "nprcgenekeepr"
        )
        div(class = "alert alert-danger",
            paste("Error rendering QC summary:", e$message))
      })
    })

    # Render QC results tables
    output$qcErrors <- DT::renderDT({
      req(qcResults())
      errors <- qcResults()$errors
      futile.logger::flog.debug(
        paste0("Rendering qcErrors table. Rows: ", nrow(errors),
               ", Cols: ", ncol(errors),
               if (nrow(errors) > 0L) {
                 paste0(", First error: ", errors$Error[1L])
               } else {
                 ""
               }),
        name = "nprcgenekeepr"
      )
      errors
    }, options = list(pageLength = 10L))

    output$qcWarnings <- DT::renderDT({
      req(qcResults())
      qcResults()$warnings
    }, options = list(pageLength = 10L))

    output$cleanedDataTable <- DT::renderDT({
      req(qcResults())
      qcResults()$cleaned
    }, options = list(pageLength = 10L, scrollX = TRUE))

    # Download handlers
    output$downloadErrors <- downloadHandler(
      filename = function() paste0("qc_errors_", Sys.Date(), ".csv"),
      content = function(file) {
        write.csv(qcResults()$errors, file, row.names = FALSE)
      }
    )

    output$downloadWarnings <- downloadHandler(
      filename = function() paste0("qc_warnings_", Sys.Date(), ".csv"),
      content = function(file) {
        write.csv(qcResults()$warnings, file, row.names = FALSE)
      }
    )

    output$downloadCleaned <- downloadHandler(
      filename = function() paste0("cleaned_studbook_", Sys.Date(), ".csv"),
      content = function(file) {
        write.csv(qcResults()$cleaned, file, row.names = FALSE)
      }
    )

    # Return reactive values for use by other modules
    list(
      cleanedStudbook = reactive({
        req(qcResults())
        qcResults()$cleaned
      }),
      genotypeData = reactive({
        req(qcResults())
        qcResults()$genotype
      }),
      qcSummary = reactive({
        req(qcResults())
        nRecords <- if (!is.null(qcResults()$cleaned)) {
          nrow(qcResults()$cleaned)
        } else {
          0L
        }
        list(
          errors = nrow(qcResults()$errors),
          warnings = nrow(qcResults()$warnings),
          records = nRecords
        )
      }),
      minSireAge = reactive({
        parseOptionalAge(input$minSireAge)
      }),
      minDamAge = reactive({
        parseOptionalAge(input$minDamAge)
      }),
      isReady = reactive({
        req(qcResults())
        nrow(qcResults()$errors) == 0L && !is.null(qcResults()$cleaned)
      }),
      debugMode = reactive(input$debugger),
      changedCols = reactive({
        req(qcResults())
        qcResults()$changedCols
      }),
      # For dynamic tab management
      errorLst = reactive({
        storedErrorLst()
      }),
      pedigreeFileName = reactive({
        storedFileName()
      })
    )
  })
}