gbiqq: Make, Update, and Query Binary Causal Models

Documented in grab

#' Grab
#'
#' Returns specified elements from a \code{causal_model}.
#' Users can use \code{grab} to extract model's components or objects implied by
#' the model structure including nodal types, causal types, parameter priors,
#' parameter posteriors, type priors, type posteriors, and other relevant elements.
#' See argument \code{object} for other options.
#'
#' @inheritParams CausalQueries_internal_inherit_params
#' @param object A character string specifying the component to retrieve.
#'   Available options are:
#'   \itemize{
#'   \item \code{"causal_statement"} a character. Statement describing causal relations using dagitty syntax,
#'   \item \code{"dag"} A data frame with columns ‘parent’ and ‘children’ indicating how nodes relate to each other,
#'   \item \code{"nodes"} A list containing the nodes in the model,
#'   \item \code{"parents_df"} a table listing nodes, whether they are root nodes or not, and the number and names of parents they have,
#'   \item \code{"parameters_df"} a data frame containing parameter information,
#'   \item \code{"causal_types"} a data frame listing causal types and the nodal types that produce them,
#'   \item \code{"causal_types_interpretation"} a key to interpreting types; see \code{"?interpret_type"} for options,
#'   \item \code{"nodal_types"} a list with the nodal types of the model,
#'   \item \code{"data_types"} a list with the all data  types consistent with the model; for options see \code{"?get_all_data_types"},
#'   \item \code{"event_probabilities"}  a vector of data (event) probabilities given a parameter vector; for options see \code{"?get_event_probabilities"},
#'   \item \code{"ambiguities_matrix"} a matrix mapping from causal types into data types,
#'   \item \code{"parameters"} a vector of 'true' parameters,
#'   \item \code{"parameter_names"} a  vector of names of parameters,
#'   \item \code{"parameter_mapping"} a  matrix mapping from parameters into data types,
#'   \item \code{"parameter_matrix"} a matrix mapping from parameters into causal types,
#'   \item \code{"prior_hyperparameters"}  a vector of alpha values used to parameterize Dirichlet prior distributions; optionally provide node names to reduce output \code{"grab(prior_hyperparameters, c('M', 'Y'))"}
#'   \item \code{"prior_distribution"}  a data frame of the parameter prior distribution,
#'   \item \code{"posterior_distribution"}  a data frame of the parameter posterior distribution,
#'   \item \code{"posterior_event_probabilities"} a sample of data (event) probabilities from the posterior,
#'   \item \code{"stan_objects"}  stan_objects is a list of Stan outputs that can include the stanfit object, the data that was used, and distributions over causal types and event probabilities.
#'   \item \code{"data"} the data that was provided to update the model,
#'   \item \code{"stan_fit"} the stanfit object generated by Stan,
#'   \item \code{"stan_summary"} a summary of the stanfit object generated by Stan,
#'   \item \code{"type_prior"} a matrix of type probabilities using priors,
#'   \item \code{"type_distribution"} a matrix of type probabilities using posteriors,
#'   }
#' @param ... Other arguments passed to helper \code{"get_*"} functions.
#' @return Objects from a \code{causal_model} as specified.
#'
#' @export
#' @examples
#' \donttest{
#' model <-
#'   make_model('X -> Y') |>
#'    update_model(
#'    keep_event_probabilities = TRUE,
#'    keep_fit = TRUE,
#'    refresh = 0 )
#'
#' grab(model, object = "causal_statement")
#' grab(model, object = "dag")
#' grab(model, object = "nodes")
#' grab(model, object = "parents_df")
#' grab(model, object = "parameters_df")
#' grab(model, object = "causal_types")
#' grab(model, object = "causal_types_interpretation")
#' grab(model, object = "nodal_types")
#' grab(model, object = "data_types")
#' grab(model, object = "event_probabilities")
#' grab(model, object = "ambiguities_matrix")
#' grab(model, object = "parameters")
#' grab(model, object = "parameter_names")
#' grab(model, object = "parameter_mapping")
#' grab(model, object = "parameter_matrix")
#' grab(model, object = "prior_hyperparameters")
#' grab(model, object = "prior_distribution")
#' grab(model, object = "posterior_distribution")
#' grab(model, object = "posterior_event_probabilities")
#' grab(model, object = "stan_objects")
#' grab(model, object = "data")
#' grab(model, object = "stan_fit")
#' grab(model, object = "stan_summary")
#' grab(model, object = "type_prior")
#' grab(model, object = "type_distribution")
#'
#' # Example of arguments passed on to helpers
#' grab(model,
#'   object = "event_probabilities",
#'   parameters = c(.6, .4, .1, .1, .7, .1))
#'
#' }
#'
grab <- function(model, object = NULL, ...) {
  switch(
    object,
    causal_statement = model$statement,
    dag = model$dag,
    nodes = model$nodes,
    parents_df = model$parents_df,
    parameters_df = model$parameters_df,
    causal_types = get_causal_types(model),
    causal_types_interpretation = interpret_type(model, ...),
    nodal_types = get_nodal_types(model, ...),
    data_types = get_all_data_types(model, ...),
    event_probabilities = get_event_probabilities(model, ...),
    ambiguities_matrix = get_ambiguities_matrix(model),
    parameters = get_parameters(model, ...),
    parameter_names = get_parameter_names(model, ...),
    parameter_mapping = get_parmap(model, ...),
    parameter_matrix = get_parameter_matrix(model),
    prior_hyperparameters = get_priors(model, ...),
    prior_distribution = get_param_dist(model, using = "priors", ...),
    posterior_distribution =
    if (is.null(model$posterior_distribution)) {
      stop(
        "Model does not contain a posterior distribution; update using update_model()"
      )
    } else {
      model$posterior_distribution
    },
    posterior_event_probabilities =
      if (is.null(model$stan_objects$event_probabilities)) {
        stop(
          "Model does not contain event_probabilities; update model with keep_event_probabilities = TRUE"
        )
      } else {
        model$stan_objects$event_probabilities
      },
    stan_objects =
      if (is.null(model$stan_objects)) {
        stop("Model does not contain stan_objects; update model")
      } else {
        model$stan_objects
      },
    data =
      if (is.null(model$stan_objects)) {
        stop("Model does not contain stan_objects; update model")
      } else {
        if (is.null(model$stan_objects$data)) print("No data provided")
        model$stan_objects$data
      },
    stan_fit =
      if (is.null(model$stan_objects$stanfit)) {
        stop("Model does not contain stanfit; update model and set  keep_fit = TRUE")
      } else {
        model$stan_objects$stanfit
      },
    stan_summary =
      if (is.null(model$stan_objects$stan_summary)) {
        stop("Model does not contain stan_fit; update model using update_model()")
      } else {
        model$stan_objects$stan_summary
      },
    type_prior =  get_type_prob_multiple(model, using = "priors") |> t(),
    type_distribution =
      if (is.null(model$stan_objects$type_distribution)) {
        stop(
          "Model does not contain type_distribution; update model with type_distribution = TRUE"
        )
      } else {
        model$stan_objects$type_distribution
      },
    stop(
      "Invalid object specified. See help for list of all available objects."
    )
  )
}