R/reference.R

In CrescNet/GrowthSDS: Utility Functions for Growth SDS Calculations

#' A reference holding reference values (LMS) for measurements.
#'
#' @slot title         reference title
#' @slot yearPublished year when reference was first published
#' @slot description   description of the reference
#' @slot doi           DOI
#' @slot ethnicGroup   ethnic group, this reference should be used for
#' @slot disorder      disorder, this reference should be used for
#' @slot values        actual LMS reference values of the reference
#' @examples
#' Reference(
#'   title       = 'My reference',
#'   ethnicGroup = list(
#'     name  = 'Germans',
#'     sctid = '7695005' # concept ID in SNOMED CT
#'   ),
#'   disorder = list(
#'     name = 'Turner syndrome',
#'     scid = '38804009'
#'   ),
#'   values = list(
#'     height = list(
#'       male = data.frame(x = c(), l = c(), m = c(), s = c())
#'     )
#'   )
#' )
#' @export
Reference <- setClass(
  'Reference',
  representation(
    title         = 'character',
    description   = 'character',
    yearPublished = 'numeric',
    doi           = 'character',
    ethnicGroup   = 'list',
    disorder      = 'list',
    values        = 'list'
  ),
  prototype(
    description   = NA_character_,
    yearPublished = NA_real_,
    doi           = NA_character_,
    ethnicGroup   = list(),
    disorder      = list(),
    values        = list()
  )
)

setGeneric('measurements', function(reference) standardGeneric('measurements'))
setGeneric('sexes', function(reference) standardGeneric('sexes'))
setGeneric('xRanges', function(reference) standardGeneric('xRanges'))

#' List available measurements of a \code{\linkS4class{Reference}} object.
#'
#' @param reference the reference object
#' @return vector containing measurement names
#' @examples measurements(GrowthSDS::cdc)
#' @export
setMethod(
  'measurements',
  'Reference',
  function(reference) {
    names(reference@values)
  }
)

#' List available sexes of a \code{\linkS4class{Reference}} object.
#'
#' @param reference the reference object
#' @return list of measurements with respective supported sexes
#' @examples sexes(GrowthSDS::cdc)
#' @export
setMethod(
  'sexes',
  'Reference',
  function(reference) {
    purrr::map(reference@values, function(measurement) {
      names(measurement)
    })
  }
)

#' List available measurements of a \code{\linkS4class{Reference}} object.
#'
#' @param reference the reference object
#' @return list of measurements and sexes with respective x min and max values
#' @examples xRanges(GrowthSDS::cdc)
#' @export
setMethod(
  'xRanges',
  'Reference',
  function(reference) {
    purrr::map(reference@values, function(measurement) {
      purrr::map(measurement, function(sex) {
        c(min(sex$x), max(sex$x))
      })
    })
  }
)

#' Construct a new reference from a data.frame.
#'
#' @param title         reference title
#' @param yearPublished year when reference was first published
#' @param description   description of the reference
#' @param doi           DOI
#' @param ethnicGroup   ethnic group, this reference should be used for
#' @param disorder      disorder, this reference should be used for
#' @param values        data.frame with columns: measurement, sex, x (e.g. (gestational) age), l, m, s
#' @return a new Reference object
#' @examples
#' Reference_df(
#'   title         = 'CDC',
#'   yearPublished = 2000,
#'   description   = NA_character_,
#'   doi           = NA_character_,
#'   ethnicGroup   = list(),
#'   disorder      = list(),
#'   values        = data.frame(
#'     measurement = c(),
#'     sex = c(),
#'     x = c(),
#'     l = c(),
#'     m = c(),
#'     s = c()
#'   )
#' )
#' @export
Reference_df <- function(
  title         = NA_character_,
  yearPublished = NA_real_,
  description   = NA_character_,
  doi           = NA_character_,
  ethnicGroup   = list(),
  disorder      = list(),
  values        = c()
) {
  reference <- Reference(title = title, yearPublished = yearPublished, description = description, doi = doi, ethnicGroup = ethnicGroup, disorder = disorder)
  for (measurement in unique(values$measurement)) {
    for (sex in unique(values$sex[values$measurement == measurement])) {
      lms <- values[values$measurement == measurement & values$sex == sex,]
      reference@values[[measurement]][[sex]] <- data.frame(x = lms$x, l = lms$l, m = lms$m, s = lms$s)
    }
  }
  reference
}

#' Combine two references to a new reference
#'
#' You must provide a x value where both references will be glued together.
#' All values of the first reference with smaller or equal x
#' and all values of the second one with greater x will be combined.
#' If x.cut is missing, all values of both references will be combined.
#'
#' @param ref1 first reference
#' @param ref2 second reference
#' @param x.cut x cutoff, see description
#' @return a new Reference object
#' @export
combineReferences <- function(ref1, ref2, x.cut) {
  newRef <- Reference()
  for (measurement in names(ref1@values)) {
    for (sex in names(ref1@values[[measurement]])) {
      newRef@values[[measurement]][[sex]] <- rbind(
        ref1@values[[measurement]][[sex]][ref1@values[[measurement]][[sex]]$x <= ifelse(missing(x.cut), Inf, x.cut),],
        ref2@values[[measurement]][[sex]][ref2@values[[measurement]][[sex]]$x >  ifelse(missing(x.cut), -Inf, x.cut),]
      )
    }
  }
  newRef
}

#' List all references, included in this package.
#'
#' @return data.frame with columns 'Item' and 'Title'
#' @examples standardReferences()
#' @export
standardReferences <- function() {
  data.frame(data(package = 'GrowthSDS')$results[,c (3, 4)])
}

#' Get values of the reference for a specific measurement, and optional x values and sexes.
#'
#' @param ref Reference object
#' @param measurement measurement for which values should be selected
#' @param x specific x values for which LMS values should be selected (and approximated if necessary)
#' @param sex sex for which values should be selected
#' @return data.frame with columns 'x', 'l', 'm' and 's'
#' @examples subsetReference(kromeyerHauschild, 'height', c(0, 10))
#' @export
subsetReference <- function(ref, measurement, x, sex) {
  if (!measurement %in% measurements(ref)) {
    stop(sprintf(
      "Reference '%s' has no measurement '%s'! Possible values are: %s",
      ref@title, measurement, paste(measurements(ref), collapse = ', ')
    ))
  }

  values <- ref@values[[measurement]]

  if (!missing(sex)) {
    sexes <- sexes(ref)[[measurement]]
    if (all(!sex %in% sexes)) {
      stop(sprintf(
        "Measurement '%s' in reference '%s' has no sex '%s'! Possible values are: %s",
        measurement, ref@title, sex, paste(sexes, collapse = ', ')
      ))
    }
    values <- values[names(values) %in% sex]
  }

  if (missing(x)) return(values)

  return(purrr::map2(values, names(values), function(values, sex) {
    purrr::map_dfr(unique(x), function(x) {
      purrr::map(values, function(param) {
        stats::approx(values$x, param, x, rule = 2)$y
      })
    })
  }))
}