R/result.R

In simulab: Simulates a Wide Variety of Data Shapes, Sizes and Distributions

#' List the tidy tables available from a simulation
#'
#' @param x A `simulab_sim` object.
#'
#' @return A base `data.frame` with one row per available table and the columns
#'   `table` (the name to pass as `what` to `as.data.frame()`), `rows` and
#'   `columns`. The first row is always the primary `"data"` table; a result
#'   that carries no extra tables returns that single row.
#' @export
#'
#' @examples
#' result <- simulate_ttest(
#'   n_a = 10,
#'   n_b = 10,
#'   mean_a = 0,
#'   mean_b = 0.5,
#'   seed = 1
#' )
#' components(result)
components <- function(x) {
  stopifnot(
    "`x` must be a `simulab_sim` or `simulab_tna` object" =
      inherits(x, c("simulab_sim", "simulab_tna"))
  )

  tables <- if (inherits(x, "simulab_tna")) {
    attr(x, "simulab_tables")
  } else {
    c(list(data = .plain_data(x)), attr(x, "simulab_tables"))
  }
  data.frame(
    table = names(tables),
    rows = vapply(tables, nrow, integer(1)),
    columns = vapply(tables, ncol, integer(1)),
    row.names = NULL,
    stringsAsFactors = FALSE
  )
}

.new_simulab_sim <- function(data, type, seed = NULL, tables = list()) {
  stopifnot(
    "`data` must be a data frame" =
      is.data.frame(data),
    "`type` must be a single string" =
      is.character(type) &&
        length(type) == 1L,
    "`seed` must be NULL or a single number" =
      is.null(seed) || (is.numeric(seed) && length(seed) == 1L),
    "`tables` must be a list of data frames" =
      is.list(tables) &&
        all(vapply(tables, is.data.frame, logical(1)))
  )

  result <- data
  class(result) <- c("simulab_sim", "data.frame")
  attr(result, "simulab_type") <- type
  attr(result, "simulab_seed") <- seed
  attr(result, "simulab_tables") <- tables
  result
}

.plain_data <- function(x) {
  stopifnot(
    "`x` must be a data frame" =
      is.data.frame(x)
  )

  result <- x
  class(result) <- "data.frame"
  attr(result, "simulab_type") <- NULL
  attr(result, "simulab_seed") <- NULL
  attr(result, "simulab_tables") <- NULL
  result
}

#' Convert a simulation component to a tidy data frame
#'
#' @param x A `simulab_sim` object.
#' @param row.names Ignored.
#' @param optional Ignored.
#' @param what Single string naming the table to return, default `"data"` for
#'   the primary simulated observations. Use `components(x)` to list the
#'   available choices; an unrecognized name is an error that lists them.
#' @param ... Reserved for future methods.
#'
#' @return A plain base `data.frame` (the `simulab_sim` class and attributes
#'   are dropped) containing the requested simulation table.
#' @export
#'
#' @examples
#' result <- simulate_ttest(
#'   n_a = 10,
#'   n_b = 10,
#'   mean_a = 0,
#'   mean_b = 0.5,
#'   seed = 1
#' )
#' as.data.frame(result)
#' as.data.frame(result, what = "parameters")
as.data.frame.simulab_sim <- function(x, row.names = NULL, optional = FALSE,
                                      what = "data", ...) {
  stopifnot(
    "`x` must be a `simulab_sim` object" =
      inherits(x, "simulab_sim"),
    "`what` must be a single string that is not NA" =
      is.character(what) &&
        length(what) == 1L &&
        !is.na(what)
  )

  if (identical(what, "data")) {
    return(.plain_data(x))
  }

  tables <- attr(x, "simulab_tables")
  if (!what %in% names(tables)) {
    stop(
      sprintf(
        "Unknown table '%s'. Available tables: %s.",
        what,
        paste(c("data", names(tables)), collapse = ", ")
      ),
      call. = FALSE
    )
  }

  tables[[what]]
}

#' Print a simulation result
#'
#' Prints a one-line header giving the simulation type and the full dimensions,
#' then at most the first 10 rows of the primary data, then a count of the rows
#' not shown. The table of generating values follows under the heading
#' `Truth`: the first of `coefficients`, `fixed_effects`, `parameters`,
#' `transition`, `transitions`, `true_transitions`, `definitions`,
#' `probabilities`, `survival_definitions` and `settings` that the result
#' stores, again at most 10 rows. A last line names the other stored tables,
#' which `as.data.frame()` returns with `what`.
#'
#' @param x A `simulab_sim` object.
#' @param ... Arguments passed to the base data-frame print method.
#'
#' @return `x`, invisibly.
#' @export
#'
#' @examples
#' result <- simulate_ttest(n_a = 30, n_b = 30, mean_a = 0, mean_b = 0.5, seed = 1)
#' print(result)
print.simulab_sim <- function(x, ...) {
  stopifnot(
    "`x` must be a `simulab_sim` object" =
      inherits(x, "simulab_sim")
  )

  shown <- utils::head(.plain_data(x), 10L)
  cat(sprintf(
    "<simulab_sim:%s> %d rows x %d columns\n",
    attr(x, "simulab_type"),
    nrow(x),
    ncol(x)
  ))
  print(shown, ...)
  if (nrow(x) > nrow(shown)) {
    cat(sprintf("... %d more rows\n", nrow(x) - nrow(shown)))
  }
  tables <- attr(x, "simulab_tables")
  truth_name <- .truth_table_name(names(tables))
  if (!is.null(truth_name)) {
    truth <- tables[[truth_name]]
    truth_shown <- utils::head(truth, 10L)
    rownames(truth_shown) <- NULL
    cat(sprintf("\nTruth (%s):\n", truth_name))
    print(truth_shown, ...)
    if (nrow(truth) > nrow(truth_shown)) {
      cat(sprintf("... %d more rows\n", nrow(truth) - nrow(truth_shown)))
    }
  }
  others <- setdiff(names(tables), truth_name)
  if (length(others)) {
    cat(sprintf(
      "\nOther tables: %s. Read one with as.data.frame(x, what = \"%s\").\n",
      paste(others, collapse = ", "), others[1L]
    ))
  }
  invisible(x)
}

# The table a reader means by "the true values" of a result, by precedence;
# NULL when the result stores none of them.
.truth_table_name <- function(table_names) {
  precedence <- c("coefficients", "fixed_effects", "parameters", "transition",
                  "transitions", "true_transitions", "definitions",
                  "probabilities", "survival_definitions", "settings")
  found <- intersect(precedence, table_names)
  if (length(found)) found[1L] else NULL
}

#' Summarize simulated variables
#'
#' Summarizes the primary data only; the other components are not included.
#'
#' @param object A `simulab_sim` object.
#' @param ... Reserved for future methods.
#'
#' @return A base `data.frame` with one row per column of the primary data and
#'   the columns `variable`, `class`, `observations`, `missing`, `unique`,
#'   `mean`, `sd`, `minimum` and `maximum`. The last four are `NA` for
#'   non-numeric columns.
#' @export
#'
#' @examples
#' result <- simulate_ttest(n_a = 30, n_b = 30, mean_a = 0, mean_b = 0.5, seed = 1)
#' summary(result)
summary.simulab_sim <- function(object, ...) {
  stopifnot(
    "`object` must be a `simulab_sim` object" =
      inherits(object, "simulab_sim")
  )

  data <- .plain_data(object)
  summarize_column <- function(value, variable) {
    stopifnot(
      "`variable` must be a single string" =
        is.character(variable) &&
          length(variable) == 1L
    )

    numeric_value <- if (is.numeric(value)) value else numeric(0L)
    data.frame(
      variable = variable,
      class = class(value)[1L],
      observations = length(value),
      missing = sum(is.na(value)),
      unique = length(unique(value[!is.na(value)])),
      mean = if (length(numeric_value)) mean(numeric_value, na.rm = TRUE) else NA_real_,
      sd = if (length(numeric_value)) stats::sd(numeric_value, na.rm = TRUE) else NA_real_,
      minimum = if (length(numeric_value)) min(numeric_value, na.rm = TRUE) else NA_real_,
      maximum = if (length(numeric_value)) max(numeric_value, na.rm = TRUE) else NA_real_,
      row.names = NULL,
      stringsAsFactors = FALSE
    )
  }

  summaries <- Map(summarize_column, data, names(data))
  do.call(rbind, summaries)
}