R/biases.R

In louisahsmith/simpleSens: What the Package Does (One Line, Title Case)

#' @title Unmeasured confounding
#'
#' @description
#' A type of bias. Declares that unmeasured confounding will be a component of
#' interest in the the sensitivity analysis. Generally used within other
#' functions; its output is returned invisibly.
#'
#' @param ... Other arguments. Not currently used for this function.
#' @param message Logical. If `TRUE`, returns warnings and messages immediately.
#'   Defaults to `FALSE` because it is generally used within the
#'   [calculate_evalue()] or [calculate_bound()] functions, which will print the
#'   same messages/warnings.
#' @return Invisibly returns a list with components `n` (2, the degree of the
#'   polynomial in the numerator), `d` (1, the degree of the polynomial in the
#'   denominator), `m` ("RR_UY", "RR_AU", the parameters in the bias factor),
#'   `mess` (any messages/warnings that should be printed for the user), and
#'   `bias` ("confounding").
#'
#' @examples
#' confounding()
#' output <- confounding()
#' output
#'
#' # Calculate an E-value for unmeasured confounding
#' calculate_evalue(RRobs = 4, biases = list(confounding()))
#'
#'@export

confounding <- function(..., message = FALSE) {
  arguments <- c(...)
  mess <- NULL

  if (!is.null(arguments)) {
    mess <- "Additional options are not currently accepted for confounding and have been ignored"
  }

  m <- c("RR_UY", "RR_AU")
  mess_e <- paste0(
    "This E-value for unmeasured confounding refers to ",
    combine_words(m), " (see documentation)"
  )

  if (message) {
    warning(mess)
    message(mess_e)
  }

  invisible(list(n = 2, d = 1, m = m, mess = mess, bias = "confounding"))
}



#' @title Selection bias
#'
#' @description
#' A type of bias. Declares that selection bias will be a component of interest
#' in the sensitivity analysis. Generally used within other functions; its
#' output is returned invisibly.
#'
#' @param ... Optional arguments describing the type of potential selection
#'   bias. Options are "general" (general selection bias, the default if no
#'   options are chosen), "increased_risk" and "decreased_risk" (assumptions
#'   about the direction of risk in the selected population), "S = U"
#'   (simplification used if the biasing characteristic is common to the entire
#'   selected population), and "selected" (when the target of inference is the
#'   selected population only). Errors are produced when incompatible
#'   assumptions are chosen.
#' @param message Logical. If `TRUE`, returns warnings and messages immediately.
#'   Defaults to `FALSE` because it is generally used within the
#'   [calculate_evalue()] or [calculate_bound()] functions, which will print the
#'   same messages/warnings.
#' @return Invisibly returns a list with components whose values depend on the
#'   options chosen: `n` (the degree of the polynomial in the numerator), `d`
#'   (the degree of the polynomial in the denominator), `m` (the parameters in
#'   the bias factor), `mess` (any messages/warnings that should be printed for
#'   the user), and `bias`("selection").
#'
#' @examples
#' selection("selected")
#' output <- selection("general", "decreased_risk", "S = U")
#' output
#'
#' # Calculate an E-value for selection bias
#' calculate_evalue(RRobs = 4,
#'          biases = selection("general", "increased_risk"))
#'
#' @export

selection <- function(..., message = FALSE) {
  arguments <- c(...)
  mess <- NULL

  # if nothing chosen, assume general selection bias with no assumptions
  if (is.null(arguments)) {
    arguments <- "general"
    mess <- "The default option, general selection bias, is being used"
  }

  type <- match.arg(arguments,
                    c("general", "selected", "S = U", "increased risk", "decreased risk"),
                    several.ok = TRUE
  )

  if (length(arguments) > length(type)) {
    nomatch <- setdiff(arguments, type)
    mess <- paste(mess,
                  paste0("'", nomatch, "' is/are not valid options for selection bias and have been ignored"),
                  sep = "\n"
    )
  }

  # if selected population has been chosen as well as any other option
  # return with error
  if ("selected" %in% type && length(type) > 1) {
    stop("These assumptions are incompatible; choose 'general' instead of 'selected'")
  }

  if ("increased risk" %in% type && "decreased risk" %in% type) {
    stop("These assumptions are incompatible; choose either increased or decreased risk")
  }

  # if neither target population was selected
  if (!"general" %in% type && !"selected" %in% type) {
    type <- c(type, "general")
    mess <- paste(mess, "The default option, general selection bias, is being used as well",
                  sep = "\n"
    )
  }

  poss_args <- list(
    "general" = list(
      n = 4, d = 2,
      m = c("RR_UY|A=0", "RR_UY|A=1", "RR_SU|A=0", "RR_SU|A=1")
    ),
    "selected" = list(
      n = 2, d = 1,
      m = c("RR_UY|S=1", "RR_AU|S=1")
    ),
    "S = U" = list(
      n = -2, d = -2,
      m = c("RR_UY|A=0", "RR_UY|A=1")
    ),
    "increased risk" = list(
      n = -2, d = -1,
      m = c("RR_UY|A=1", "RR_SU|A=1")
    ),
    "decreased risk" = list(
      n = -2, d = -1,
      m = c("RR_UY|A=0", "RR_SU|A=0")
    )
  )

  # find the degrees in the numerator and denominator
  n <- Reduce(
    f = "+",
    sapply(poss_args[type], function(x) x$n)
  )
  d <- Reduce(
    f = "+",
    sapply(poss_args[type], function(x) x$d)
  )
  # if both increased/decreased risk and S = U chosen, then there's an overlap
  # in degrees taken away, so add back in
  if("S = U" %in% type && ("increased risk" %in% type || "decreased risk" %in% type)) {
    n <- n + 1
    d <- d + 1
  }

  m <- Reduce(
    f = c,
    sapply(poss_args[type], function(x) x$m)
  )

  # find the parameters to which the E-value refers
  # ie those that are show up for each of the options used
  m <- names(table(m))[table(m) == length(type)]
  mess_e <- paste0(
    "This selection bias E-value refers to ",
    combine_words(m), " (see documentation)"
  )

  # remove any leading line breaks just for aesthetics
  if (!is.null(mess)) {
    if (substr(mess, 1, 1) == "\n") mess <- substr(mess, 2, nchar(mess))
  }

  if (message) {
    warning(mess)
    message(mess_e)
  }

  invisible(list(n = n, d = d, m = m, mess = mess, bias = "selection"))
}


#' @title Misclassification
#'
#' @description
#' A type of bias. Declares that (differential) misclassification will be a
#' component of interest in the sensitivity analysis. Generally used within
#' other functions; its output is returned invisibly.
#'
#' @param ... Arguments describing the type of misclassification. Currently two
#'   options: "outcome" or "exposure".
#' @param outcome_rare Logical. Is the outcome rare enough that outcome odds
#'   ratios approximate risk ratios? Only needed when considering exposure
#'   misclassification.
#' @param exposure_rare Logical. Is the exposure rare enough that exposure odds
#'   ratios approximate risk ratios? Only needed when considering exposure
#'   misclassification.
#' @param message Logical. If `TRUE`, returns warnings and messages immediately.
#'   Defaults to `FALSE` because it is generally used within the
#'   [calculate_evalue()] or [calculate_bound()] functions, which will print the
#'   same messages/warnings.
#'
#' @return Invisibly returns a list with components whose values depend on the
#'   options chosen: `n` (the degree of the polynomial in the numerator), `d`
#'   (the degree of the polynomial in the denominator), `m` (the parameters in
#'   the bias factor), `mess` (any messages/warnings that should be printed for
#'   the user), and `bias`("misclassification").
#'
#' @examples
#' misclassification("exposure", outcome_rare = TRUE, exposure_rare = FALSE)
#' output <- misclassification("outcome")
#' output
#'
#' # Calculate an E-value for misclassification
#' calculate_evalue(RRobs = 4,
#'          biases = misclassification("exposure",
#'                   outcome_rare = TRUE, exposure_rare = TRUE))
#'
#'@export


misclassification <- function(...,
                              outcome_rare = NULL, exposure_rare = NULL,
                              message = FALSE) {
  arguments <- c(...)
  mess <- NULL

  if (is.null(arguments)) {
    stop("Either 'outcome' or 'exposure' must be chosen as an option")
  }

  type <- match.arg(arguments,
                    c("outcome", "exposure"),
                    several.ok = TRUE
  )

  if (length(arguments) > length(type)) {
    nomatch <- setdiff(arguments, type)
    mess <- paste(mess,
                  paste0("'", nomatch, "' is/are not valid options for missclassification and have been ignored"),
                  sep = "\n"
    )
  }

  if ("outcome" %in% type && "exposure" %in% type) {
    stop("Only one of 'exposure' and 'outcome' can be chosen.")
  }

  if (type == "outcome" &&
      (length(arguments) > 1 || !is.null(outcome_rare) || !is.null(exposure_rare))) {
    mess <- paste(mess,
                  "No other arguments are necessary for outcome misclassfication; they have been ignored",
                  sep = "\n"
    )
  }

  if (type == "outcome") {
    mess_e <- "This E-value for misclassification refers to RR_AY*|y (see documentation)"

    # remove any leading line breaks just for aesthetics
    if (!is.null(mess)) {
      if (substr(mess, 1, 1) == "\n") mess <- substr(mess, 2, nchar(mess))
    }

    if (message) {
      warning(mess)
      message(mess_e)
    }
    return(invisible(list(n = 1, d = 0, m = "RR_AY*|y", mess = mess, bias = "misclassification")))
  }

  if (type == "exposure" && is.null(outcome_rare) && is.null(exposure_rare)) {
    stop("For exposure misclassification, arguments outcome_rare and exposure_rare must be TRUE or FALSE")
  }

  if (type == "exposure" && !outcome_rare) {
    stop("Not currently available for multiple bias analysis")
  }

  # only have type = exposure left
  m <- "RR_YA*|a"

  mess_e <- paste0("This E-value for misclassification refers to ", m, " (see documentation)")

  # remove any leading line breaks just for aesthetics
  if (!is.null(mess)) {
    if (substr(mess, 1, 1) == "\n") mess <- substr(mess, 2, nchar(mess))
  }

  if (message) {
    warning(mess)
    message(mess_e)
  }

  if (exposure_rare) {
    return(invisible(list(n = 1, d = 0, m = m, mess = mess, bias = "misclassification")))
  }

  # if common exposure, this is actually an odds ratio, so is sqare-rooted to become a risk ratio
  invisible(list(n = 2, d = 0, m = m, mess = mess, bias = "misclassification"))
}


get_opts_misclassification <- function() {
  message(paste(
    "You must choose one of 'outcome', 'exposure'.",
    "Additionally, if 'exposure' is chosen, you must also specify",
    "outcome_rare = TRUE/FALSE and exposure_rare = TRUE/FALSE"
  ))
  invisible(c("outcome", "exposure", "outcome_rare", "exposure_rare"))
}

get_opts_confounding <- function() {
  message(paste("Currently no options for confounding are needed."))
}

get_opts_selection <- function() {
  message(paste(
    "The default is general selection bias, which you",
    "can specify explicitly with 'general'. Other options",
    "available with 'general' are 'increased_risk',",
    "'decreased_risk', and 'S = U'. Alternatively you can",
    "choose 'selected' for inference in the selected population."
  ))
  invisible(c("general", "increased_risk", "decreased_risk", "S = U", "selected"))
}

all_opts <- c(get_opts_confounding(), get_opts_selection(), get_opts_misclassification())