R/active.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ============================================================================
# R4VN active-data state and public active-data command
# ============================================================================

# Internal active-data state. The active data may be linked to a named data
# frame object. When linked, R4VN editing commands update both the active copy
# and the original object, so the object remains visible and current in the
# RStudio Environment pane.
.r4vn_state <- new.env(parent = emptyenv())
.r4vn_state$data <- NULL
.r4vn_state$name <- NULL
.r4vn_state$source <- NULL
.r4vn_state$object_name <- NULL
.r4vn_state$object_env <- NULL
.r4vn_state$model <- NULL
.r4vn_state$model_result <- NULL
.r4vn_state$margins <- NULL

.r4vn_has_active <- function() is.data.frame(.r4vn_state$data)

.r4vn_find_binding_env <- function(name, env) {
  current <- env
  repeat {
    if (exists(name, envir = current, inherits = FALSE)) return(current)
    if (identical(current, emptyenv())) break
    current <- parent.env(current)
  }
  NULL
}

.r4vn_has_link <- function() {
  is.character(.r4vn_state$object_name) &&
    length(.r4vn_state$object_name) == 1L &&
    nzchar(.r4vn_state$object_name) &&
    is.environment(.r4vn_state$object_env)
}

.r4vn_drop_link <- function() {
  .r4vn_state$object_name <- NULL
  .r4vn_state$object_env <- NULL
  invisible(NULL)
}

.r4vn_refresh_active <- function() {
  if (!.r4vn_has_link()) return(invisible(FALSE))
  name <- .r4vn_state$object_name
  env <- .r4vn_state$object_env
  if (!exists(name, envir = env, inherits = FALSE)) {
    .r4vn_drop_link()
    return(invisible(FALSE))
  }
  value <- get(name, envir = env, inherits = FALSE)
  if (!is.data.frame(value)) {
    .r4vn_drop_link()
    return(invisible(FALSE))
  }
  .r4vn_state$data <- value
  invisible(TRUE)
}

.r4vn_get_active <- function(required = TRUE) {
  .r4vn_refresh_active()
  if (!.r4vn_has_active()) {
    if (isTRUE(required)) {
      stop(
        "No active data frame. Use `usedf(data)` or ",
        "`opendata(..., active = TRUE)` first.",
        call. = FALSE
      )
    }
    return(NULL)
  }
  .r4vn_state$data
}

.r4vn_set_active <- function(data, name = NULL, source = NULL, quiet = FALSE,
                             object_name = NULL, object_env = NULL) {
  if (!is.data.frame(data)) stop("Active data must be a data frame.", call. = FALSE)

  linked <- is.character(object_name) && length(object_name) == 1L &&     nzchar(object_name) && is.environment(object_env) &&     exists(object_name, envir = object_env, inherits = FALSE) &&     !bindingIsLocked(object_name, object_env)

  .r4vn_state$data <- data
  .r4vn_state$name <- if (is.null(name) || !nzchar(name)) "<active>" else as.character(name)[1L]
  .r4vn_state$source <- source
  .r4vn_state$object_name <- if (linked) object_name else NULL
  .r4vn_state$object_env <- if (linked) object_env else NULL

  if (linked) assign(object_name, data, envir = object_env)

  if (!isTRUE(quiet)) {
    message(
      "Active data: ", .r4vn_state$name,
      " (", nrow(data), " observations, ", ncol(data), " variables)",
      if (linked) " [linked]" else ""
    )
  }

  invisible(data)
}

.r4vn_clear_active <- function(quiet = FALSE) {
  .r4vn_state$data <- NULL
  .r4vn_state$name <- NULL
  .r4vn_state$source <- NULL
  .r4vn_drop_link()
  if (!isTRUE(quiet)) message("Active data cleared.")
  invisible(NULL)
}

.r4vn_active_name <- function() {
  if (.r4vn_has_active()) .r4vn_state$name else NULL
}

.r4vn_active_source <- function() {
  if (.r4vn_has_active()) .r4vn_state$source else NULL
}

.r4vn_active_link <- function() {
  if (!.r4vn_has_link()) return(NULL)
  list(name = .r4vn_state$object_name, env = .r4vn_state$object_env)
}

.r4vn_object_target <- function(expr, env) {
  if (!is.symbol(expr)) {
    stop(
      "When editing an explicit data frame, `data` must be a bare object name.",
      call. = FALSE
    )
  }

  name <- as.character(expr)
  binding_env <- .r4vn_find_binding_env(name, env)
  if (is.null(binding_env)) stop("Data object `", name, "` was not found.", call. = FALSE)

  data <- get(name, envir = binding_env, inherits = FALSE)
  if (!is.data.frame(data)) stop("`", name, "` is not a data frame.", call. = FALSE)

  list(
    mode = "object",
    name = name,
    data = data,
    env = binding_env,
    source = NULL,
    object_name = name,
    object_env = binding_env
  )
}

.r4vn_active_target <- function() {
  link <- .r4vn_active_link()
  list(
    mode = "active",
    name = .r4vn_active_name(),
    data = .r4vn_get_active(),
    env = NULL,
    source = .r4vn_active_source(),
    object_name = if (is.null(link)) NULL else link$name,
    object_env = if (is.null(link)) NULL else link$env
  )
}

.r4vn_try_data_frame <- function(expr, env) {
  tryCatch(
    {
      value <- eval(expr, envir = env)
      if (is.data.frame(value)) value else NULL
    },
    error = function(e) NULL
  )
}

.r4vn_first_dot_is_named <- function(exprs) {
  if (!length(exprs)) return(FALSE)
  nms <- names(exprs)
  !is.null(nms) && nzchar(nms[1L])
}

.r4vn_edit_context <- function(exprs, data_expr = NULL,
                               data_supplied = FALSE, env) {
  target <- NULL

  if (isTRUE(data_supplied)) {
    value <- eval(data_expr, envir = env)

    if (is.null(value)) {
      target <- .r4vn_active_target()
    } else {
      target <- .r4vn_object_target(data_expr, env)
    }
  } else if (length(exprs) && !.r4vn_first_dot_is_named(exprs)) {
    candidate <- .r4vn_try_data_frame(exprs[[1L]], env)

    if (is.data.frame(candidate)) {
      target <- .r4vn_object_target(exprs[[1L]], env)
      exprs <- exprs[-1L]
    }
  }

  if (is.null(target)) target <- .r4vn_active_target()

  list(
    data = target$data,
    args = exprs,
    target = target
  )
}

.r4vn_read_context <- function(exprs, data_expr = NULL,
                               data_supplied = FALSE, env) {
  if (isTRUE(data_supplied)) {
    value <- eval(data_expr, envir = env)

    if (is.null(value)) {
      return(list(data = .r4vn_get_active(), args = exprs))
    }
    if (!is.data.frame(value)) stop("`data` must be a data frame.", call. = FALSE)

    return(list(data = value, args = exprs))
  }

  if (length(exprs) && !.r4vn_first_dot_is_named(exprs)) {
    candidate <- .r4vn_try_data_frame(exprs[[1L]], env)

    if (is.data.frame(candidate)) {
      return(list(data = candidate, args = exprs[-1L]))
    }
  }

  list(data = .r4vn_get_active(), args = exprs)
}

.r4vn_same_binding <- function(name1, env1, name2, env2) {
  is.character(name1) && is.character(name2) &&
    length(name1) == 1L && length(name2) == 1L &&
    identical(name1, name2) && is.environment(env1) &&
    is.environment(env2) && identical(env1, env2)
}

.r4vn_commit_context <- function(target, data) {
  if (!is.data.frame(data)) stop("Edited result is not a data frame.", call. = FALSE)

  if (identical(target$mode, "active")) {
    if (is.character(target$object_name) && length(target$object_name) == 1L &&
        nzchar(target$object_name) && is.environment(target$object_env)) {
      assign(target$object_name, data, envir = target$object_env)
    }
    .r4vn_set_active(
      data,
      name = target$name,
      source = target$source,
      quiet = TRUE,
      object_name = target$object_name,
      object_env = target$object_env
    )
  } else {
    assign(target$name, data, envir = target$env)

    link <- .r4vn_active_link()
    if (!is.null(link) &&
        .r4vn_same_binding(target$name, target$env, link$name, link$env)) {
      .r4vn_set_active(
        data,
        name = target$name,
        source = .r4vn_active_source(),
        quiet = TRUE,
        object_name = target$name,
        object_env = target$env
      )
    }
  }

  invisible(data)
}

.r4vn_resolve_analysis_data <- function(data = NULL) {
  if (is.null(data)) return(.r4vn_get_active())
  if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)
  data
}

#' Set or inspect the active data frame
#'
#' Makes a data frame the default data source for R4VN commands. When a bare
#' object name is supplied, such as `usedf(patient)`, the active data remains
#' linked to that object. R4VN editing commands such as `genvar()`,
#' `replacevar()`, `labvar()`, `renvar()`, `dropvar()`, `keepvar()`, and
#' `ordervar()` then update the object itself as well as the active data.
#'
#' If an expression rather than a bare object name is supplied, R4VN stores an
#' unlinked working copy. Use `newdata <- usedf()` to retrieve that copy.
#'
#' @param data Optional data frame to make active.
#' @param clear Logical; clear active data.
#' @param quiet Logical; suppress status messages.
#'
#' @return The active data frame invisibly, or `NULL` after clearing.
#' @export
#'
#' @examples
#' patient <- data.frame(id = 1:3, age = c(20, 30, 40))
#' usedf(patient, quiet = TRUE)
#'
#' # Editing active data also updates patient
#' genvar(age2 = age^2)
#' names(patient)
#'
#' # Manual changes to patient are seen by later active-data commands
#' patient$age[1] <- 21
#' usedf(quiet = TRUE)$age
#'
#' usedf(clear = TRUE, quiet = TRUE)
#'
#' # Extended usage examples
#' \donttest{
#' patient <- data.frame(id = 1:4, age = c(20, 30, 40, 50))
#'
#' # Set a visible object as active data. The object remains in Environment.
#' usedf(patient)
#' usedf()
#'
#' # R4VN editing commands update both active data and patient.
#' genvar(age10 = age / 10, label = "Age in decades")
#' labvar(age, label = "Age in years")
#' names(patient)
#' if (interactive()) View(patient)
#'
#' # Manual changes to patient are visible to later active-data commands.
#' patient$age[1] <- 21
#' sum1(age)
#'
#' # An expression creates an unlinked working copy.
#' usedf(subset(patient, age >= 30))
#' genvar(age2 = age^2)
#' working_copy <- usedf()
#'
#' # Return to the linked object or clear active data.
#' usedf(patient)
#' usedf(clear = TRUE)
#' }
usedf <- function(data, clear = FALSE, quiet = FALSE) {
  if (isTRUE(clear)) return(.r4vn_clear_active(quiet))

  if (missing(data)) {
    out <- .r4vn_get_active(required = FALSE)
    if (is.null(out)) {
      if (!isTRUE(quiet)) message("No active data frame.")
      return(invisible(NULL))
    }
    if (!isTRUE(quiet)) {
      message(
        "Active data: ", .r4vn_state$name,
        " (", nrow(out), " observations, ", ncol(out), " variables)",
        if (.r4vn_has_link()) " [linked]" else ""
      )
    }
    return(invisible(out))
  }

  if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)

  expr <- substitute(data)
  env <- parent.frame()
  display_name <- paste(deparse(expr, width.cutoff = 500L), collapse = "")
  object_name <- NULL
  object_env <- NULL

  if (is.symbol(expr)) {
    candidate_name <- as.character(expr)
    candidate_env <- .r4vn_find_binding_env(candidate_name, env)
    if (!is.null(candidate_env)) {
      candidate <- get(candidate_name, envir = candidate_env, inherits = FALSE)
      if (is.data.frame(candidate)) {
        object_name <- candidate_name
        object_env <- candidate_env
      }
    }
  }

  .r4vn_set_active(
    data,
    name = display_name,
    quiet = quiet,
    object_name = object_name,
    object_env = object_env
  )
}

# Active-model state ---------------------------------------------------------
#
# R4VN statistical model commands automatically store their most recently
# fitted underlying model here.  Postestimation commands such as margins(),
# predict(), and lincom() can therefore behave like Stata and operate on the
# last fitted model when `model`/`object` is omitted.
.r4vn_set_active_model <- function(model, result = NULL) {
  if (is.null(model)) return(invisible(NULL))
  .r4vn_state$model <- model
  .r4vn_state$model_result <- result
  invisible(model)
}

.r4vn_get_active_model <- function(required = TRUE, result = FALSE) {
  out <- if (isTRUE(result)) .r4vn_state$model_result else .r4vn_state$model
  if (is.null(out) && isTRUE(required)) {
    stop(
      "No active model is available. Fit a model first or supply `model = ...`.",
      call. = FALSE
    )
  }
  out
}

.r4vn_set_last_margins <- function(x) {
  .r4vn_state$margins <- x
  invisible(x)
}

.r4vn_get_last_margins <- function(required = TRUE) {
  x <- .r4vn_state$margins
  if (is.null(x) && isTRUE(required)) {
    stop("No margins result is available. Run `margins()` first or supply its result.", call. = FALSE)
  }
  x
}