R/getPedigreeSource.R

In nprcgenekeepr: Genetic Tools for Colony Management

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

#' Get a normalized pedigree from a pluggable data source
#'
#' Internal data-source adapter for the pedigree fetch boundary used by
#' \code{getLkDirectRelatives()}. It isolates the brittle LabKey pull behind a
#' single seam and makes LabKey one pluggable provider among several
#' (\code{"labkey"}, \code{"dataframe"}, \code{"file"}), which also enables
#' offline, deterministic testing via the \code{"dataframe"} and \code{"file"}
#' sources.
#'
#' @param sourceType one of \code{"labkey"} (pull demographics via
#' \code{getDemographics()} and rename to the package's internal column names),
#' \code{"dataframe"} (use a caller-supplied, already-normalized pedigree -- the
#' offline/deterministic seam), or \code{"file"} (read a pedigree file via
#' \code{getPedigree()}).
#' @param siteInfo (\code{"labkey"} only) site configuration list; defaults to
#' \code{getSiteInfo()}. Supplies \code{lkPedColumns} (the columns to pull) and
#' \code{mapPedColumns} (the one-to-one rename to the internal column names).
#' @param ped (\code{"dataframe"} only) an already-normalized pedigree
#' data.frame containing at least \code{id}, \code{sire}, and \code{dam}.
#' @param fileName (\code{"file"} only) path to a pedigree file (CSV or Excel)
#' read via \code{getPedigree()}; the file must provide at least \code{id},
#' \code{sire}, and \code{dam} columns.
#' @param sep (\code{"file"} only) column separator passed to
#' \code{getPedigree()} for delimited text files (default \code{","}).
#' @return A normalized pedigree data.frame with columns \code{id}, \code{sex},
#' \code{birth}, \code{death}, \code{exit}, \code{dam}, and \code{sire}. The
#' \code{"labkey"} source returns \code{NULL} when its fetch fails (warning or
#' error), preserving the fail-soft contract \code{getLkDirectRelatives()}
#' relies on; the \code{"dataframe"} and \code{"file"} sources return the
#' supplied or read pedigree and error on invalid input.
#'
#' @importFrom futile.logger flog.debug
#' @importFrom stringi stri_c
#' @noRd
getPedigreeSource <- function(sourceType = c("labkey", "dataframe", "file"),
                              siteInfo = NULL, ped = NULL,
                              fileName = NULL, sep = ",") {
  sourceType <- match.arg(sourceType)
  requirePedColumns <- function(p, subject) {
    if (!all(c("id", "sire", "dam") %in% names(p))) {
      stop(
        "getPedigreeSource(): ", subject, " must contain columns ",
        "id, sire, and dam.",
        call. = FALSE
      )
    }
  }
  if (sourceType == "dataframe") {
    if (is.null(ped) || !is.data.frame(ped)) {
      stop(
        "getPedigreeSource(): 'ped' must be a data.frame for ",
        "source = 'dataframe'.",
        call. = FALSE
      )
    }
    requirePedColumns(ped, "'ped'")
    return(ped)
  }

  if (sourceType == "file") {
    if (is.null(fileName)) {
      stop(
        "getPedigreeSource(): 'fileName' must be supplied for ",
        "source = 'file'.",
        call. = FALSE
      )
    }
    if (!file.exists(fileName)) {
      stop(
        "getPedigreeSource(): file not found: ", fileName,
        call. = FALSE
      )
    }
    ped <- getPedigree(fileName, sep = sep)
    requirePedColumns(ped, "file pedigree")
    return(ped)
  }

  if (is.null(siteInfo)) {
    # getSiteInfo() is wrapped in tryCatch (mirroring the getDemographics
    # guard below) so a present-but-malformed config file can never crash
    # this call site -- BACKLOG.md's "4 remaining unguarded getSiteInfo()
    # call sites". Only `error` is caught, not `warning`: a missing config
    # file WARNS but still returns usable defaults, which is not a failure.
    siteInfo <- tryCatch(getSiteInfo(),
      error = function(cond) {
        flog.debug(
          stri_c("Error generated by getSiteInfo in getPedigreeSource: ",
                  cond),
          name = "nprcgenekeepr"
        )
        NULL
      }
    )
    if (is.null(siteInfo)) {
      return(NULL)
    }
  }
  msgSource <- " generated by getDemographics in getPedigreeSource: "
  pedSourceDf <- tryCatch(getDemographics(colSelect = siteInfo$lkPedColumns),
    warning = function(cond) {
      flog.debug(stri_c("Warning", msgSource, cond),
        name = "nprcgenekeepr"
      )
      NULL
    },
    error = function(cond) {
      flog.debug(stri_c("Error", msgSource, cond),
        name = "nprcgenekeepr"
      )
      NULL
    }
  )
  if (is.null(pedSourceDf)) {
    return(NULL)
  }
  names(pedSourceDf) <- siteInfo$mapPedColumns
  pedSourceDf
}