R/evalue.R

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

#'@title Calculate a multiple-bias E-value
#'
#'@description Calculate an E-value for a specified set of biases.
#'
#'@param RRobs A number. The value of the risk ratio that was observed but which
#'  is suspected to be biased.
#'@param biases A list of biases to include in the calculation of the E-value.
#'  May include any or all of [confounding()], [selection()], and
#'  [misclassification()], and any of the options described in the documentation
#'  for those functions.
#'@param message Logical. Whether or not to print a message with the parameters
#'  the E-value refers to. Defaults to `TRUE`.
#'@return Returns a multiple bias E-value describing the value that each of a
#'  number of parameters would have to have for `RRobs` to be completely
#'  explained by bias. A message is printed listing the parameters that the
#'  value refers to.
#'
#' @examples
#' # Calculate an E-value for unmeasured confounding
#' calculate_evalue(RRobs = 4, biases = confounding())
#'
#' # Calculate an E-value for selection bias and misclassification
#' calculate_evalue(RRobs = 2.5,
#'          biases = list(selection("selected"), misclassification("outcome")))
#'
#' # Calculate an E-value for all three available types of bias
#' calculate_evalue(RRobs = 1.4234,
#'          biases = list(selection("general", "S = U"),
#'                        misclassification("exposure", outcome_rare = TRUE,
#'                                                      exposure_rare = TRUE),
#'                        confounding()))
#'
#' @export
#' @importFrom stats uniroot

calculate_evalue <- function(RRobs, biases, message = TRUE) {
  # just add an extra element in case there's only one type of bias
  # or else sapply won't work
  if ("mess" %in% names(biases)) biases <- list(list(d = 0, n = 0), biases)
  # add up the degrees across the biases
  n <- Reduce(f = "+", sapply(biases, function(x) x$n))
  d <- Reduce(f = "+", sapply(biases, function(x) x$d))
  # and combine all the parameters
  m <- unlist(sapply(biases, function(x) x$m))
  mess <- sapply(biases, function(x) x$mess)
  mess <- paste(mess[!sapply(mess, is.null)], collapse = "\n")
  mess <- paste0(
    mess,
    "\nThis multiple bias E-value refers simultaneously to ",
    length(m), " parameters:\n",
    combine_words(m), "\n(see documentation for definitions)"
  )
  if (message) message(mess)
  uniroot(
    f = deg_func, y = RRobs, n = n, d = d,
    interval = c(1 - 1e-9, RRobs), extendInt = "upX"
  )$root
}