R/bound.R

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

#' @title Get information about the bias parameters
#'
#' @description
#' Function used to return the information about the parameters that define a
#' given combination of biases.
#'
#' @param biases A list of biases to include.
#'   May include any or all of [confounding()], [selection()], and
#'   [misclassification()], and any of the options described in the
#'   documentation for those functions.
#' @return Returns a dataframe with information about the parameters defining
#'   the biases. Columns include the name of the parameter used in the package
#'   messages, the corresponding name of the argument used in the
#'   [calculate_bound()] function, the type of bias the parameter corresponds to,
#'   and a simple interpretation of that parameter. Useful for getting
#'   information about the required arguments of [calculate_bound()] or
#'   information on interpreting the output of [calculate_evalue()].
#'
#' @examples
#' get_param_info(biases = list(confounding()))
#'
#' get_param_info(biases = list(selection("selected"),
#'                              misclassification("outcome")))
#'
#' get_param_info(biases =
#'                list(selection("general", "S = U"),
#'                     misclassification("exposure",
#'                             outcome_rare = TRUE,
#'                             exposure_rare = TRUE),
#'                     confounding()))
#'
#' @export

get_param_info <- function(biases) {
  # 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(NULL, biases)
  necc_params <- c(sapply(biases, function(x) x$m))
  bias_names <- c(sapply(biases, function(x) x$bias))
  bias_names <- unname(unlist(mapply(rep, bias_names, sapply(necc_params, length))))
  poss_params <- unlist(necc_params)
  param_args <- gsub("[^a-zA-Z0-9]", "", poss_params)
  data.frame(cbind("necessary parameter" = poss_params,
                   "argument name" = param_args,
                   "bias" = bias_names),
             row.names = NULL, stringsAsFactors = FALSE)
}

#' @title Calculate a bound for the bias
#'
#' @description
#' Function used to calculate the maximum factor by which a risk ratio is
#' biased, given possible values for each of the parameters that describe the
#' bias factors for each type of bias.
#'
#' @param ... Named parameter values with which to calculate a
#'   bound. Names must correspond to the parameters defining the biases
#'   provided by `biases`. Help with names can be found by running
#'   `get_param_info(biases)` for the biases of interest. Unnecessary parameters
#'   are ignored with a warning.
#' @param biases A list of biases to include in the calculation of the bound.
#'   May include any or all of [confounding()], [selection()], and
#'   [misclassification()], and any of the options described in the
#'   documentation for those functions.
#' @return Returns the value of the bound formed as a function of the
#'   provided parameters.
#'
#' @examples
#' calculate_bound(RRAU = 2.2, RRUY = 1.7,
#'                biases = list(confounding()))
#'
#' calculate_bound(RRUY = 3, RRAU = 2, RRUYA0 = 2.3,
#'                         RRUYA1 = 5.2, RRYAa = 8.3,
#'                biases = list(
#'                         confounding(), selection("S = U"),
#'                         misclassification("exposure",
#'                         outcome_rare = TRUE, exposure_rare = FALSE)
#'                         ))
#'
#' @export

calculate_bound <- function(..., biases) {
  params <- c(...)
  necc_params <- get_param_info(biases)

  if (!all(necc_params$argument.name %in% names(params))) {
    err_mess <- paste0(
      "You are missing parameters necessary to calculate a bound,",
      " or they have missing or incorrect names.",
      " You need to supply a list of values with the following names: ",
      combine_words(necc_params$argument.name)
    )
    stop(err_mess)
  }

  if (length(names(params)) > length(necc_params$argument.name)) {
    warning(paste(
      "You seem to have supplied uncessary parameters.",
      "Check to make sure you have chosen the appropriate biases.",
      "These are the parameters that are being used:",
      combine_words(necc_params$argument.name)
    ))
  }

  necc_params$vals <- NA
  for (i in seq_len(nrow(necc_params))) {
    necc_params$vals[i] <- unlist(params[necc_params$argument.name[i]])
  }

  conf_vals <- necc_params$vals[necc_params$bias == "confounding"]
  miscl_vals <- necc_params$vals[necc_params$bias == "misclassification"]
  sel1_vals <- necc_params$vals[necc_params$bias == "selection" &
                                  grepl("1", necc_params$argument.name)]
  sel0_vals <- necc_params$vals[necc_params$bias == "selection" &
                                  grepl("0", necc_params$argument.name)]

  # add on a 1 to selection values if it's only length 1,
  # which will make it easy to use the rr function no matter what
  if (length(sel1_vals) == 1) sel1_vals <- c(sel1_vals, 1)
  if (length(sel0_vals) == 1) sel0_vals <- c(sel0_vals, 1)


  conf_prod <- if (length(conf_vals) > 1) bf_func(conf_vals[1], conf_vals[2]) else 1
  miscl_prod <- if (length(miscl_vals) > 0) miscl_vals else 1
  sel1_prod <- if (length(sel1_vals) > 1) bf_func(sel1_vals[1], sel1_vals[2]) else 1
  sel0_prod <- if (length(sel0_vals) > 1) bf_func(sel0_vals[1], sel0_vals[2]) else 1

  return(conf_prod * miscl_prod * sel1_prod * sel0_prod)
}