R/diagnosis_helper_functions.R

Defines functions clean_bootstrap_df reshape_diagnosis print_summary_diagnosis summary.diagnosis print.diagnosis get_simulations get_diagnosands

Documented in get_diagnosands get_simulations reshape_diagnosis

#' Explore your design diagnosis
#'
#' @param diagnosis A design diagnosis created by \code{\link{diagnose_design}}.
#'
#' @examples
#' design <- 
#'   declare_model(
#'     N = 500, 
#'     U = rnorm(N),
#'     Y_Z_0 = U, 
#'     Y_Z_1 = U + rnorm(N, mean = 2, sd = 2)
#'   ) + 
#'   declare_assignment(Z = complete_ra(N)) + 
#'   declare_inquiry(ATE = mean(Y_Z_1 - Y_Z_0)) + 
#'   declare_measurement(Y = reveal_outcomes(Y ~ Z)) +
#'   declare_estimator(Y ~ Z, inquiry = "ATE") 
#'
#' \dontrun{
#' # using built-in defaults:
#' diagnosis <- diagnose_design(design)
#' diagnosis
#' }
#'
#' # using a user-defined diagnosand
#' my_diagnosand <- declare_diagnosands(
#'   absolute_error = mean(abs(estimate - estimand)))
#'
#' \dontrun{
#' diagnosis <- diagnose_design(design, diagnosands = my_diagnosand)
#' diagnosis
#'
#' get_diagnosands(diagnosis)
#'
#' get_simulations(diagnosis)
#'
#' reshape_diagnosis(diagnosis)
#'
#' }
#'
#' @name diagnosis_helpers
NULL

#' @rdname diagnosis_helpers
#' @export
get_diagnosands <- function(diagnosis) {
  diagnosis$diagnosands
}

#' @rdname diagnosis_helpers
#' @export
get_simulations <- function(diagnosis) {
  diagnosis$simulations
}

#' @export
print.diagnosis <- function(x, digits = 2, select = NULL, exclude = NULL, ...) {
  print_summary_diagnosis(x, digits = digits, select = select, exclude = exclude)
}

#' @export
summary.diagnosis <- function(object, digits = 2, select = NULL, exclude = NULL, ...) {
  print_summary_diagnosis(object, digits = digits, select = select, exclude = exclude)
}

print_summary_diagnosis <- function(x, digits = 2, select = NULL, exclude = NULL, ...) {
  n_sims <- unique(x$diagnosands_df$n_sims)
  cat(paste0("\nResearch design diagnosis", ifelse(length(n_sims) == 1, paste0(" based on ", n_sims, " simulations"), ""), "."))
  if (x$bootstrap_sims > 0) {
    cat(" Diagnosand estimates with bootstrapped standard errors in parentheses (", x$bootstrap_sims, " replicates).", sep = "")
  }
  cat("\n\n")
  x <- reshape_diagnosis(x, digits = digits, select = select, exclude = exclude)
  class(x) <- "data.frame"
  print(x, row.names = FALSE)
  invisible(x)
}


#' Clean up a diagnosis object for printing
#'
#' Take a diagnosis object and returns a pretty output table. If diagnosands are bootstrapped, se's are put in parentheses on a second line and rounded to \code{digits}.
#'
#' @param diagnosis A diagnosis object generated by \code{diagnose_design}. 
#' @param digits Number of digits.
#' @param select List of columns to include in output. Defaults to all.
#' @param exclude Set of columns to exclude from output. Defaults to none.
#' @return A formatted text table with bootstrapped standard errors in parentheses.
#' @export
#'
#' @examples
#' # library(DesignLibrary)
#' # diagnosis <- diagnose_design(two_arm_designer(), sims = 3)
#' # reshape_diagnosis(diagnosis)
#' # reshape_diagnosis(diagnosis, select = c("Bias", "Power"))
reshape_diagnosis <- function(diagnosis, digits = 2, select = NULL, exclude = NULL) {
  diagnosand_columns <- diagnosis$diagnosand_names

  diagnosands_df <- diagnosis$diagnosands

  parameter_names <- names(diagnosis$parameters_df)[-1]

  if (is.data.frame(diagnosis$bootstrap_replicates)) {
    diagnosand_se_columns <- paste0("se(", diagnosis$diagnosand_names, ")")
    group_columns <- setdiff(names(diagnosands_df), c(diagnosand_columns, diagnosand_se_columns))
    return_df <- clean_bootstrap_df(
      diagnosis, digits, diagnosand_columns,
      diagnosand_se_columns, group_columns,
      parameter_names, sort_by_list
    )
  } else {
    group_columns <- setdiff(names(diagnosands_df), diagnosand_columns)
    return_df <- diagnosands_df
    
    return_df[diagnosand_columns] <- lapply(return_df[diagnosand_columns], 
                                            format_num, digits = digits)
  }

  # Reorder rows
  sort_by_list <- diagnosis$group_by_set %icn% return_df

  return_df <- return_df[do.call(order, as.list(return_df[, sort_by_list])), , drop = FALSE]

  # blank cells for SE rows
  for(i in c(parameter_names, "design")) {
    levels(return_df[[i]]) <- c(levels(return_df[[i]]), "")
  }
  return_df$estimator <- as.character(return_df$estimator)
  
  for(j in c(sort_by_list, parameter_names)) if(is.factor(return_df[[j]]) && !"" %in% levels(return_df[[j]]))
    return_df[[j]] <- factor(return_df[[j]], levels = c(levels(return_df[[j]]), ""))
  
  return_df[return_df$statistic == "SE", c(sort_by_list, parameter_names, "n_sims")] <- ""
  return_df$statistic <- NULL

  # Make names nicer
  make_nice_names <- function(x) {
    gsub("\\b(se[(]|sd |rmse|[[:alpha:]])",
      "\\U\\1",
      gsub("_", " ", x),
      perl = TRUE
    )
  }

  names_to_change <- setdiff(names(return_df), parameter_names)
  names(return_df)[names(return_df) %in% names_to_change] <- make_nice_names(names_to_change)

  # Select columns
  if (!is.null(select)) {
    available_to_select <- make_nice_names(c(group_columns, diagnosand_columns))
    if (!all(select %in% available_to_select)) {
      stop(paste(
        "select argument must only include elements from: ",
        paste(available_to_select, collapse = ", ")
      ))
    }

    return_df <- return_df[, c(make_nice_names(c(sort_by_list, "n_sims")), select), drop = FALSE]
  }

  rownames(return_df) <- NULL
  
  if(!is.null(exclude))
    return_df <- return_df[, names(return_df)[!(names(return_df) %in% exclude)]] 
  
  return(return_df)
}

clean_bootstrap_df <- function(diagnosis, digits, diagnosand_columns,
                               diagnosand_se_columns, group_columns,
                               parameter_names, sort_by_list) {
  diagnosands_df <- diagnosis$diagnosands

  # Make diagnosand only df
  diagnosands_only_df <-
    diagnosands_df[, c(group_columns, diagnosand_columns), drop = FALSE]

  clean_values_df <-
    data.frame(lapply(diagnosands_only_df[, diagnosand_columns, drop = FALSE],
      format_num,
      digits = digits
    ), stringsAsFactors = FALSE)

  diagnosands_only_df <-
    cbind(
      diagnosands_only_df[, group_columns, drop = FALSE],
      data.frame(statistic = "Estimate", stringsAsFactors = FALSE),
      clean_values_df
    )

  names(diagnosands_only_df) <- c(group_columns, "statistic", diagnosand_columns)

  # Make se only df
  se_only_df <- diagnosands_df[, diagnosand_se_columns, drop = FALSE]
  se_only_df <- data.frame(lapply(se_only_df, add_parens, digits = digits), stringsAsFactors = FALSE)
  colnames(se_only_df) <- diagnosand_columns

  se_only_df <- cbind(
    diagnosands_only_df[, group_columns, drop = FALSE],
    data.frame(statistic = "SE", stringsAsFactors = FALSE), se_only_df
  )

  # Merge
  return_df <- rbind_disjoint(list(diagnosands_only_df, se_only_df), infill = "")

  # NA bootstrap rows
  return_df$design <- factor(return_df$design)
  return_df$design <- factor(return_df$design, levels = c(levels(return_df$design), ""))

  return(return_df)
}

Try the DeclareDesign package in your browser

Any scripts or data that you put into this service are public.

DeclareDesign documentation built on Aug. 21, 2021, 5:07 p.m.