R/design_print_summary.R

In DeclareDesign/ddoldversion: Declare and Diagnose Research Designs

#' @param x a design object, typically created using the + operator
#' @rdname declare_design
#' @export
print.design <- function(x, verbose = TRUE, ...) {
  print(summary(x, verbose = verbose, ... = ...))
}

#' @param object a design object created using the + operator
#' @param verbose an indicator for printing a long summary of the design, defaults to \code{TRUE}
#' @param ... optional arguments to be sent to summary function
#'
#' @rdname declare_design
#'
#' @examples
#'
#' my_population <- declare_population(N = 500, noise = rnorm(N))
#'
#' my_potential_outcomes <- declare_potential_outcomes(
#'   Y_Z_0 = noise, Y_Z_1 = noise +
#'   rnorm(N, mean = 2, sd = 2))
#'
#' my_sampling <- declare_sampling(n = 250)
#'
#' my_assignment <- declare_assignment(m = 25)
#'
#' my_estimand <- declare_estimand(ATE = mean(Y_Z_1 - Y_Z_0))
#'
#' my_estimator <- declare_estimator(Y ~ Z, estimand = my_estimand)
#'
#' my_mutate <- declare_step(dplyr::mutate, noise_sq = noise ^ 2)
#'
#' my_reveal <- declare_reveal()
#'
#' design <- my_population +
#'   my_potential_outcomes +
#'   my_sampling +
#'   my_estimand +
#'   my_mutate +
#'   my_assignment +
#'   my_reveal +
#'   my_estimator
#'
#' summary(design)
#' @rdname post_design
#' @export
#' @importFrom rlang is_call call_args
summary.design <- function(object, verbose = TRUE, ...) {
  design <- object
  
  title <- NULL
  authors <- NULL
  
  get_formula_from_step <- function(step) {
    call <- attr(step, "call")
    type <- attr(step, "step_type")
    if (is_call(call) && is.character(type) && type != "wrapped") {
      formulae <- Filter(is_formula, call_args(call))
      if (length(formulae) == 1) {
        return(formulae[[1]])
      }
    }
    return(NULL)
  }
  
  variables_added <- variables_modified <-
    quantities_added <- quantities_modified <-
    N <- extra_summary <-
    vector("list", length(design))
  
  formulae <- lapply(design, get_formula_from_step)
  calls <- lapply(design, attr, "call")
  
  current_df <- design[[1]]()
  
  var_desc <- variables_added[[1]] <- lapply(current_df, describe_variable)
  
  N[[1]] <- paste0("N = ", nrow(current_df))
  
  estimates_df <- estimands_df <- data.frame()
  
  last_df <- current_df
  
  for (i in 1 + seq_along(design[-1])) {
    causal_type <- attr(design[[i]], "causal_type")
    if (is.null(causal_type)) next
    
    extra_summary[i] <- list(attr(design[[i]], "extra_summary"))
    
    # if it's a dgp
    if (causal_type == "dgp") {
      current_df <- design[[i]](last_df)
      
      variables_added_names <-
        get_added_variables(last_df = last_df, current_df = current_df)
      
      variables_modified_names <-
        get_modified_variables(last_df = last_df, current_df = current_df)
      
      if (!is.null(variables_added_names)) {
        variables_added[[i]] <-
          lapply(
            current_df[, variables_added_names, drop = FALSE],
            describe_variable
          )
        var_desc[variables_added_names] <- variables_added[[i]]
      }
      
      if (!is.null(variables_modified_names)) {
        v_mod <- lapply(
          current_df[, variables_modified_names, drop = FALSE],
          describe_variable
        )
        variables_modified[[i]] <- mapply(list,
                                          before = var_desc[variables_modified_names],
                                          after = v_mod,
                                          SIMPLIFY = FALSE, USE.NAMES = TRUE
        )
        var_desc[variables_modified_names] <- v_mod
      }
      
      N[i] <- local({
        c_row <- nrow(current_df)
        l_row <- nrow(last_df)
        if (c_row == l_row) {
          list(NULL)
        } else {
          sprintf(
            "N = %d (%d %s)", c_row, abs(c_row - l_row),
            ifelse(c_row > l_row, "added", "subtracted")
          )
        }
      })
      
      last_df <- current_df
    } else if (causal_type %in% c("estimand", "estimator")) {
      quantities_added[[i]] <- design[[i]](current_df)
    }
  }
  
  citation <- attr(design, "citation")
  if (!is.character(citation)) {
    title <- citation$title
    authors <- citation$author
  } 
  
  function_types <- lapply(design, attr, "step_type")
  
  structure(
    list(
      variables_added = variables_added,
      quantities_added = quantities_added,
      variables_modified = variables_modified,
      function_types = function_types,
      N = N,
      call = calls,
      formulae = formulae,
      title = title,
      authors = authors,
      citation = citation,
      extra_summary = extra_summary,
      verbose = verbose
    ),
    class = c("summary.design", "list")
  )
}

#' @export
print.summary.design <- function(x, ...) {
  cat("\nDesign Summary\n\n")
  
  if (!is.null(x$title)) {
    cat("Study title: ", x$title, ifelse(is.null(x$authors), "\n\n", ""), sep = "")
  }
  
  if (!is.null(x$authors)) {
    cat(
      ifelse(!is.null(x$title), "\n", ""),
      "Authors: ",
      paste0(x$authors, collapse = ", "),
      "\n\n",
      sep = ""
    )
  }
  
  for (i in 1:max(length(x$variables_added), length(x$quantities_added))) {
    step_name <- if (is.null(x$call[[i]])) "" else deparse(x$call[[i]])
    step_class <-
      ifelse(
        x$function_types[[i]] != "unknown",
        gsub("_", " ", x$function_types[[i]]),
        "custom data modification"
      )
    
    dash_width <-
      max(c(80 - 11 - nchar(i) - nchar(step_class) - nchar(step_name[1]), 0))
    
    cat(
      "Step ",
      i,
      " (",
      step_class,
      "): ",
      step_name,
      " ",
      paste0(rep("-", dash_width), collapse = ""),
      "\n\n",
      sep = ""
    )
    
    if (x$verbose == TRUE) {
      if (!is.null(x$N[[i]])) {
        cat(x$N[[i]], "\n\n")
      }
      
      if (!is.null(x$formulae[[i]])) {
        cat("Formula:", deparse(x$formula[[i]]), "\n\n")
      }
      if (is.character(x$extra_summary[[i]])) {
        cat(x$extra_summary[[i]], "\n\n")
      }
      
      if (!is.null(x$quantities_added[[i]])) {
        if (class(x$quantities_added[[i]]) == "data.frame") {
          cat("A single draw of the ", x$function_types[[i]], ":\n", sep = "")
          print(x$quantities_added[[i]], row.names = FALSE)
          cat("\n")
        } else {
          cat(x$quantities_added[[i]], sep = "\n")
          cat("\n")
        }
      }
      if (!is.null(x$variables_added[[i]])) {
        for (j in seq_along(x$variables_added[[i]])) {
          cat("Added variable:", names(x$variables_added[[i]])[j], "\n")
          print(x$variables_added[[i]][[j]], row.names = FALSE)
          cat("\n")
        }
      }
      if (!is.null(x$variables_modified[[i]])) {
        for (j in seq_along(x$variables_modified[[i]])) {
          cat(
            "Altered variable:",
            names(x$variables_modified[[i]])[j],
            "\n  Before: \n"
          )
          print(x$variables_modified[[i]][[j]][["before"]], row.names = FALSE)
          cat("\n  After:\n")
          print(x$variables_modified[[i]][[j]][["after"]], row.names = FALSE)
          cat("\n")
        }
      }
    }
  }
  
  if (!is.null(x$citation)) {
    cat("Citation:\n")
    print(x$citation)
  }
  
  invisible(x)
}