R/shapevar.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

#' Reshape Data Between Wide and Long Formats
#'
#' Converts repeated-measures data from wide to long format or from long to
#' wide format using base R only. The active R4VN data frame is used when
#' `data` is omitted.
#'
#' @param to Optional target shape: `"long"` or `"wide"`. The shorter R4VN-style
#'   alternatives `long = TRUE` and `wide = TRUE` are also supported.
#' @param long,wide Logical shortcuts. Use exactly one when `to` is omitted.
#' @param id One or more subject/record identifier variables. Use a bare name or
#'   `vars(...)`.
#' @param vars Variables to reshape, usually supplied by `vars(...)`.
#' @param time Name of the time/index variable. In wide-to-long conversion this
#'   is the new time variable; in long-to-wide conversion it is an existing
#'   variable.
#' @param value Name of the new value variable for wide-to-long conversion.
#'   Ignored for long-to-wide conversion.
#' @param times Optional values assigned to the repeated wide columns. When
#'   omitted, `shapevar()` tries to infer suffixes from the selected variable
#'   names and otherwise uses `1, 2, ...`.
#' @param sep Separator between value-variable names and time values when
#'   creating wide variable names.
#' @param data Optional explicit data-frame object. When omitted, active data is
#'   reshaped and replaced directly.
#' @param quiet Logical; suppress the reshape summary.
#'
#' @details
#' Wide to long example:
#'
#' `shapevar(long = TRUE, id = id, vars = vars(bp1, bp2, bp3),`
#' `         time = visit, value = bp)`
#'
#' Long to wide example:
#'
#' `shapevar(wide = TRUE, id = id, time = visit, vars = vars(bp))`
#'
#' For long-to-wide conversion, each `id` by `time` combination must be unique.
#' Variables not included in `vars` are preserved when they are constant within
#' each ID. A changing non-reshaped variable triggers an error rather than being
#' silently discarded.
#'
#' @return The reshaped data frame invisibly.
#' @export
#'
#' @examples
#' wide <- data.frame(id = 1:2, sex = c("F", "M"),
#'                    bp1 = c(120, 130), bp2 = c(118, 128), bp3 = c(116, 125))
#' usedf(wide, quiet = TRUE)
#' shapevar(long = TRUE, id = id, vars = vars(bp1, bp2, bp3),
#'          time = visit, value = bp, quiet = TRUE)
#' long <- usedf(quiet = TRUE)
#' shapevar(wide = TRUE, id = id, time = visit, vars = vars(bp), quiet = TRUE)
shapevar <- function(to = NULL, long = FALSE, wide = FALSE, id, vars, time = time,
                     value = value, times = NULL, sep = "_",
                     data = NULL, quiet = FALSE) {
  if (!is.logical(long) || length(long) != 1L || is.na(long) ||
      !is.logical(wide) || length(wide) != 1L || is.na(wide)) {
    stop("`long` and `wide` must be TRUE or FALSE.", call. = FALSE)
  }
  if (is.null(to)) {
    if (sum(c(long, wide)) != 1L) stop("Use exactly one of `long = TRUE` or `wide = TRUE`.", call. = FALSE)
    to <- if (isTRUE(long)) "long" else "wide"
  } else {
    to <- match.arg(as.character(to)[1L], c("long", "wide"))
    if (isTRUE(long) || isTRUE(wide)) stop("Use `to` or the `long`/`wide` shortcut, not both.", call. = FALSE)
  }
  env <- parent.frame()
  data_supplied <- !missing(data) && !is.null(data)

  if (data_supplied) {
    data_expr <- substitute(data)
    if (!is.symbol(data_expr)) stop("Explicit `data` must be a bare data-frame object name.", call. = FALSE)
    data_name <- as.character(data_expr)
    d <- eval(data_expr, envir = env)
    if (!is.data.frame(d)) stop("`data` must be a data frame.", call. = FALSE)
  } else {
    d <- .r4vn_get_active()
    data_name <- .r4vn_active_name()
  }

  id_names <- .r4vn_names_from_expr(substitute(id), names(d))
  reshape_names <- .r4vn_names_from_expr(substitute(vars), names(d))
  if (!length(id_names)) stop("At least one `id` variable is required.", call. = FALSE)
  if (!length(reshape_names)) stop("At least one variable is required in `vars`.", call. = FALSE)

  name_from_expr <- function(expr, default) {
    if (is.symbol(expr)) return(as.character(expr))
    value0 <- tryCatch(eval(expr, envir = env), error = function(e) NULL)
    if (is.character(value0) && length(value0) == 1L && nzchar(value0)) return(value0)
    default
  }

  time_name <- name_from_expr(substitute(time), "time")
  value_name <- name_from_expr(substitute(value), "value")

  if (to == "long") {
    if (any(id_names %in% reshape_names)) stop("`id` variables cannot also appear in `vars`.", call. = FALSE)
    fixed_names <- setdiff(names(d), reshape_names)
    if (time_name %in% fixed_names) stop("The new time variable `", time_name, "` already exists.", call. = FALSE)
    if (value_name %in% fixed_names) stop("The new value variable `", value_name, "` already exists.", call. = FALSE)

    if (is.null(times)) {
      nms <- reshape_names
      suffix <- sub("^.*?([0-9]+)$", "\\1", nms, perl = TRUE)
      numeric_suffix <- grepl("[0-9]+$", nms)
      if (all(numeric_suffix) && length(unique(suffix)) == length(nms)) {
        times0 <- suppressWarnings(as.numeric(suffix))
      } else {
        times0 <- seq_along(reshape_names)
      }
    } else {
      times0 <- times
      if (length(times0) != length(reshape_names)) stop("`times` must match the number of variables in `vars`.", call. = FALSE)
    }

    value_meta <- lapply(d[reshape_names], function(x) list(label = attr(x, "label", exact = TRUE), values = attr(x, "r4vn_values", exact = TRUE)))
    value_classes <- vapply(d[reshape_names], function(x) if (is.factor(x)) "factor" else typeof(x), character(1))
    if (length(unique(value_classes)) > 1L && !all(unique(value_classes) %in% c("integer", "double"))) {
      stop("Selected wide variables have incompatible types and cannot be stacked safely.", call. = FALSE)
    }

    parts <- vector("list", length(reshape_names))
    for (j in seq_along(reshape_names)) {
      part <- d[fixed_names]
      part$.r4vn_row_order <- seq_len(nrow(d))
      part[[time_name]] <- times0[j]
      part[[value_name]] <- d[[reshape_names[j]]]
      parts[[j]] <- part
    }
    out <- do.call(rbind, parts)
    out$.r4vn_time_order <- match(out[[time_name]], times0)
    out <- out[order(out$.r4vn_row_order, out$.r4vn_time_order), , drop = FALSE]
    out$.r4vn_row_order <- NULL; out$.r4vn_time_order <- NULL
    rownames(out) <- NULL

    labs <- unique(vapply(value_meta, function(z) if (is.null(z$label)) "" else as.character(z$label)[1L], character(1)))
    labs <- labs[nzchar(labs)]
    if (length(labs) == 1L) attr(out[[value_name]], "label") <- labs
    maps <- lapply(value_meta, `[[`, "values")
    maps <- maps[lengths(maps) > 0L]
    if (length(maps) && all(vapply(maps, function(z) identical(z, maps[[1L]]), logical(1)))) attr(out[[value_name]], "r4vn_values") <- maps[[1L]]
    attr(out[[time_name]], "label") <- "Time"
  } else {
    if (!time_name %in% names(d)) stop("Time variable `", time_name, "` was not found.", call. = FALSE)
    if (time_name %in% id_names) stop("The time variable cannot also be an `id` variable.", call. = FALSE)
    if (any(reshape_names %in% c(id_names, time_name))) stop("Variables in `vars` cannot be ID or time variables.", call. = FALSE)

    key <- do.call(paste, c(lapply(d[c(id_names, time_name)], function(x) { z <- as.character(x); z[is.na(z)] <- "<NA>"; z }), sep = "\u001f"))
    if (anyDuplicated(key)) stop("Long data contain duplicate `id` x `time` combinations. Wide conversion would be ambiguous.", call. = FALSE)

    id_key <- do.call(paste, c(lapply(d[id_names], function(x) { z <- as.character(x); z[is.na(z)] <- "<NA>"; z }), sep = "\u001f"))
    groups <- split(seq_len(nrow(d)), id_key)
    fixed_candidates <- setdiff(names(d), c(reshape_names, time_name))

    changing <- character()
    for (v in setdiff(fixed_candidates, id_names)) {
      ok <- all(vapply(groups, function(ix) length(unique(d[[v]][ix])) <= 1L, logical(1)))
      if (!ok) changing <- c(changing, v)
    }
    if (length(changing)) stop("These non-reshaped variables change within ID: ", paste(changing, collapse = ", "), ". Include them in `vars` or `id` before converting to wide.", call. = FALSE)

    time_values <- if (is.factor(d[[time_name]])) levels(d[[time_name]])[levels(d[[time_name]]) %in% as.character(d[[time_name]])] else unique(d[[time_name]])
    out_rows <- vector("list", length(groups))
    for (g in seq_along(groups)) {
      ix <- groups[[g]]
      row <- d[ix[1L], fixed_candidates, drop = FALSE]
      for (v in reshape_names) {
        meta_label <- attr(d[[v]], "label", exact = TRUE)
        meta_values <- attr(d[[v]], "r4vn_values", exact = TRUE)
        for (tt in time_values) {
          hit <- ix[!is.na(d[[time_name]][ix]) & as.character(d[[time_name]][ix]) == as.character(tt)]
          new_name <- paste0(v, sep, as.character(tt))
          row[[new_name]] <- if (length(hit)) d[[v]][hit[1L]] else NA
          if (!is.null(meta_label)) attr(row[[new_name]], "label") <- paste0(meta_label, " [", tt, "]")
          if (!is.null(meta_values)) attr(row[[new_name]], "r4vn_values") <- meta_values
        }
      }
      out_rows[[g]] <- row
    }
    out <- do.call(rbind, out_rows); rownames(out) <- NULL
  }

  if (data_supplied) {
    assign(data_name, out, envir = env)
  } else {
    .r4vn_set_active(out, name = data_name, source = .r4vn_active_source(), quiet = TRUE)
  }

  if (!isTRUE(quiet)) message("Reshaped to ", to, ": ", nrow(out), " observations, ", ncol(out), " variables.")
  invisible(out)
}