R/data-management.R

In R4VN: Health Data Analysis and Publication-Ready Reporting

# ============================================================================
# R4VN data input, output, append, and merge commands
# ============================================================================

# ----------------------------------------------------------------------------
# Consolidated from: data-management-utils.R
# ----------------------------------------------------------------------------
# Internal helpers for data management. Not exported.
.r4vn_require_optional <- function(package, reason) {
  if (!requireNamespace(package, quietly = TRUE)) stop("Package `", package, "` is required ", reason, ". Install it with install.packages(\"", package, "\").", call. = FALSE)
  invisible(TRUE)
}


.r4vn_namespace_status <- function(package) {
  path <- tryCatch(find.package(package, quiet = TRUE), error = function(e) "")
  installed <- is.character(path) && length(path) == 1L && nzchar(path)
  if (!installed) return(list(ok = FALSE, installed = FALSE, error = NULL))
  err <- NULL
  ok <- tryCatch({
    requireNamespace(package, quietly = TRUE)
  }, error = function(e) {
    err <<- conditionMessage(e)
    FALSE
  })
  if (!isTRUE(ok) && is.null(err)) err <- paste0("Package `", package, "` is installed but its namespace could not be loaded.")
  list(ok = isTRUE(ok), installed = TRUE, error = err)
}

.r4vn_haven_block_message <- function(error = NULL) {
  txt <- paste(error %||% "", collapse = " ")
  blocked <- grepl("Application Control|blocked this file|LoadLibrary failure|policy has blocked", txt, ignore.case = TRUE)
  if (blocked) {
    paste0(
      "Windows Application Control blocked a compiled dependency used by `haven`",
      if (nzchar(txt)) paste0(" (", txt, ")") else "",
      ". This is an operating-system security policy rather than a corrupt Stata file. ",
      "R4VN will try a reader that does not require haven. If no fallback reader is installed, ",
      "install `readstata13` for modern Stata files or ask the system administrator to allow the R package-library DLLs."
    )
  } else if (!is.null(error) && nzchar(error)) {
    paste0("`haven` is installed but could not be loaded: ", error)
  } else {
    "Package `haven` is not available."
  }
}

.r4vn_read_stata <- function(path, labels = c("factor", "labelled", "numeric"), encoding = "UTF-8", check.names = FALSE, dots = list(), quiet = FALSE) {
  labels <- match.arg(labels)
  hs <- .r4vn_namespace_status("haven")
  haven_error <- hs$error
  if (isTRUE(hs$ok)) {
    args <- c(list(file = path, encoding = encoding), dots)
    out <- tryCatch(do.call(haven::read_dta, args), error = function(e) { haven_error <<- conditionMessage(e); NULL })
    if (!is.null(out)) return(.r4vn_process_labels(as.data.frame(out, check.names = check.names), labels))
  }
  if (requireNamespace("readstata13", quietly = TRUE)) {
    out <- tryCatch(readstata13::read.dta13(
      path, convert.factors = identical(labels, "factor"), generate.factors = FALSE,
      encoding = encoding, convert.underscore = FALSE
    ), error = function(e) NULL)
    if (!is.null(out)) {
      out <- as.data.frame(out, check.names = check.names)
      vl <- tryCatch(readstata13::varlabel(out), error = function(e) NULL)
      if (!is.null(vl)) for (nm in intersect(names(vl), names(out))) if (!is.na(vl[[nm]]) && nzchar(vl[[nm]])) attr(out[[nm]], "label") <- unname(vl[[nm]])
      if (!isTRUE(quiet) && !isTRUE(hs$ok)) message("Opened Stata data with `readstata13` fallback because `haven` was unavailable.")
      return(out)
    }
  }
  if (requireNamespace("foreign", quietly = TRUE)) {
    out <- tryCatch(foreign::read.dta(path, convert.factors = identical(labels, "factor"), convert.underscore = FALSE), error = function(e) NULL)
    if (!is.null(out)) {
      out <- as.data.frame(out, check.names = check.names)
      vl <- attr(out, "var.labels", exact = TRUE)
      if (!is.null(vl) && length(vl) == ncol(out)) for (i in seq_along(out)) if (!is.na(vl[i]) && nzchar(vl[i])) attr(out[[i]], "label") <- vl[i]
      if (!isTRUE(quiet)) message("Opened legacy Stata data with `foreign` fallback.")
      return(out)
    }
  }
  msg <- .r4vn_haven_block_message(haven_error)
  stop(msg, " Install `readstata13` with install.packages(\"readstata13\") to enable the independent Stata fallback.", call. = FALSE)
}

.r4vn_read_spss <- function(path, labels = c("factor", "labelled", "numeric"), encoding = "UTF-8", check.names = FALSE, dots = list(), quiet = FALSE) {
  labels <- match.arg(labels)
  hs <- .r4vn_namespace_status("haven"); haven_error <- hs$error
  if (isTRUE(hs$ok)) {
    args <- c(list(file = path, encoding = encoding), dots)
    out <- tryCatch(do.call(haven::read_sav, args), error = function(e) { haven_error <<- conditionMessage(e); NULL })
    if (!is.null(out)) return(.r4vn_process_labels(as.data.frame(out, check.names = check.names), labels))
  }
  if (requireNamespace("foreign", quietly = TRUE)) {
    out <- tryCatch(foreign::read.spss(path, to.data.frame = TRUE, use.value.labels = identical(labels, "factor"), trim.factor.names = FALSE), error = function(e) NULL)
    if (!is.null(out)) {
      out <- as.data.frame(out, check.names = check.names)
      if (!isTRUE(quiet)) message("Opened SPSS data with `foreign` fallback because `haven` was unavailable.")
      return(out)
    }
  }
  stop(.r4vn_haven_block_message(haven_error), " No compatible SPSS fallback reader succeeded.", call. = FALSE)
}

.r4vn_ext <- function(path) tolower(tools::file_ext(sub("\\?.*$", "", path)))

.r4vn_names_from_expr <- function(expr, data_names) {
  if (is.null(expr)) return(data_names)
  if (is.symbol(expr)) tokens <- as.character(expr)
  else if (is.character(expr)) tokens <- expr
  else if (is.call(expr) && as.character(expr[[1L]]) %in% c("vars", "c")) {
    return(unique(unlist(lapply(as.list(expr)[-1L], .r4vn_names_from_expr, data_names = data_names), use.names = FALSE)))
  } else if (is.call(expr) && identical(as.character(expr[[1L]]), ":")) {
    z <- as.list(expr)[-1L]
    left <- .r4vn_names_from_expr(z[[1L]], data_names)
    right <- .r4vn_names_from_expr(z[[2L]], data_names)
    if (length(left) != 1L || length(right) != 1L) stop("A variable range needs two variable names.", call. = FALSE)
    i <- match(left, data_names); j <- match(right, data_names)
    if (is.na(i) || is.na(j)) stop("Both ends of the variable range must exist.", call. = FALSE)
    return(data_names[seq.int(i, j)])
  } else stop("Use variable names, `vars(...)`, a range, or a character vector.", call. = FALSE)

  tokens <- trimws(unlist(strsplit(tokens, "[,[:space:]]+", perl = TRUE), use.names = FALSE))
  tokens <- tokens[nzchar(tokens)]
  out <- character()
  esc <- function(x) gsub("([][{}()+?.^$|\\\\])", "\\\\\\1", x, perl = TRUE)
  for (token in tokens) {
    if (grepl("*", token, fixed = TRUE)) {
      loc <- gregexpr("*", token, fixed = TRUE)[[1L]]
      if (length(loc) > 1L) stop("Only one `*` wildcard is supported.", call. = FALSE)
      p <- loc[1L]
      pre <- if (p > 1L) substr(token, 1L, p - 1L) else ""
      post <- if (p < nchar(token)) substr(token, p + 1L, nchar(token)) else ""
      hit <- grep(paste0("^", esc(pre), ".*", esc(post), "$"), data_names, value = TRUE)
      if (!length(hit)) stop("No variables matched `", token, "`.", call. = FALSE)
      out <- c(out, hit)
    } else {
      if (!token %in% data_names) stop("Variable `", token, "` was not found.", call. = FALSE)
      out <- c(out, token)
    }
  }
  unique(out)
}

.r4vn_eval_obs <- function(expr, data, env) {
  mask <- list2env(as.list(data), parent = env)
  assign("missing", function(x) is.na(x), envir = mask)
  rows <- eval(expr, envir = mask, enclos = env)
  if (is.logical(rows)) {
    if (length(rows) == 1L) rows <- rep(rows, nrow(data))
    if (length(rows) != nrow(data)) stop("`obs` must return one logical value per observation.", call. = FALSE)
    rows[is.na(rows)] <- FALSE
    return(rows)
  }
  if (is.numeric(rows)) {
    if (any(is.na(rows)) || any(rows < 1 | rows > nrow(data))) stop("Observation indices are out of range.", call. = FALSE)
    keep <- rep(FALSE, nrow(data)); keep[as.integer(rows)] <- TRUE
    return(keep)
  }
  stop("`obs` must be a logical condition or numeric observation indices.", call. = FALSE)
}

.r4vn_subset <- function(data, vars_expr = NULL, obs_expr = NULL, env = parent.frame()) {
  out <- data
  if (!is.null(obs_expr)) out <- out[.r4vn_eval_obs(obs_expr, out, env), , drop = FALSE]
  if (!is.null(vars_expr)) out <- out[.r4vn_names_from_expr(vars_expr, names(out))]
  rownames(out) <- NULL
  out
}

.r4vn_haven_factor <- function(x) {
  variable_label <- attr(x, "label", exact = TRUE)
  value_labels <- attr(x, "labels", exact = TRUE)
  out <- haven::as_factor(x, levels = "labels")
  if (!is.null(variable_label)) attr(out, "label") <- variable_label
  if (!is.null(value_labels)) {
    map <- names(value_labels); names(map) <- as.character(unname(value_labels))
    attr(out, "r4vn_values") <- map
  }
  out
}

.r4vn_process_labels <- function(data, labels) {
  if (!requireNamespace("haven", quietly = TRUE)) return(data)
  labelled <- vapply(data, haven::is.labelled, logical(1))
  if (!any(labelled)) return(data)
  if (labels == "factor") data[labelled] <- lapply(data[labelled], .r4vn_haven_factor)
  if (labels == "numeric") data[labelled] <- lapply(data[labelled], function(x) {
    lab <- attr(x, "label", exact = TRUE); out <- haven::zap_labels(x); if (!is.null(lab)) attr(out, "label") <- lab; out
  })
  data
}

.r4vn_factor_to_haven <- function(x) {
  map <- attr(x, "r4vn_values", exact = TRUE)
  variable_label <- attr(x, "label", exact = TRUE)
  if (is.null(map)) {
    codes <- seq_along(levels(x)); names(codes) <- levels(x)
    raw <- unname(codes[as.character(x)])
    labels <- codes
  } else {
    inverse <- stats::setNames(names(map), unname(map))
    raw_code <- unname(inverse[as.character(x)])
    numeric_raw <- suppressWarnings(as.numeric(raw_code))
    numeric_names <- suppressWarnings(as.numeric(names(map)))
    if (all(is.na(raw_code) | !is.na(numeric_raw)) && all(!is.na(numeric_names))) {
      raw <- numeric_raw; labels <- numeric_names; names(labels) <- unname(map)
    } else {
      raw <- raw_code; labels <- names(map); names(labels) <- unname(map)
    }
  }
  out <- haven::labelled(raw, labels = labels)
  if (!is.null(variable_label)) attr(out, "label") <- variable_label
  out
}

.r4vn_prepare_haven <- function(data) {
  out <- data
  fac <- vapply(out, is.factor, logical(1))
  if (any(fac)) out[fac] <- lapply(out[fac], .r4vn_factor_to_haven)
  out
}

.r4vn_redcap_post <- function(url, token, fields) {
  .r4vn_require_optional("curl", "to connect to REDCap")
  handle <- curl::new_handle()
  curl::handle_setform(handle, .list = c(list(token = token), fields))
  response <- curl::curl_fetch_memory(url, handle = handle)
  if (response$status_code < 200L || response$status_code >= 300L) stop("REDCap returned HTTP status ", response$status_code, ".", call. = FALSE)
  rawToChar(response$content)
}

.r4vn_read_csv_text <- function(text, na = c("", "NA"), encoding = "UTF-8") {
  con <- textConnection(text, encoding = encoding); on.exit(close(con), add = TRUE)
  utils::read.csv(con, na.strings = na, stringsAsFactors = FALSE, check.names = FALSE)
}

.r4vn_redcap_choices <- function(x) {
  if (is.na(x) || !nzchar(trimws(x))) return(NULL)
  items <- trimws(unlist(strsplit(x, "\\|", perl = TRUE), use.names = FALSE))
  out <- character()
  for (item in items) {
    p <- regexpr(",", item, fixed = TRUE)[1L]
    if (p < 1L) next
    code <- trimws(substr(item, 1L, p - 1L)); label <- trimws(substr(item, p + 1L, nchar(item)))
    if (nzchar(code) && nzchar(label)) out[code] <- label
  }
  if (length(out)) out else NULL
}

.r4vn_apply_redcap_metadata <- function(data, metadata, labels) {
  needed <- c("field_name", "field_label", "field_type", "select_choices_or_calculations")
  if (!all(needed %in% names(metadata))) return(data)
  for (i in seq_len(nrow(metadata))) {
    field <- metadata$field_name[i]; label <- metadata$field_label[i]; type <- tolower(metadata$field_type[i])
    choices <- .r4vn_redcap_choices(metadata$select_choices_or_calculations[i])
    if (type == "checkbox" && !is.null(choices)) {
      for (code in names(choices)) {
        v <- paste0(field, "___", code)
        if (!v %in% names(data)) next
        attr(data[[v]], "label") <- paste0(label, ": ", unname(choices[code]))
        if (labels == "factor") {
          data[[v]] <- factor(as.character(data[[v]]), levels = c("0", "1"), labels = c("No", "Yes"))
          attr(data[[v]], "label") <- paste0(label, ": ", unname(choices[code]))
          attr(data[[v]], "r4vn_values") <- c("0" = "No", "1" = "Yes")
        }
      }
      next
    }
    if (!field %in% names(data)) next
    if (!is.na(label) && nzchar(label)) attr(data[[field]], "label") <- label
    if (type %in% c("yesno", "truefalse") && is.null(choices)) choices <- c("0" = "No", "1" = "Yes")
    if (!is.null(choices) && labels == "factor") {
      raw <- as.character(data[[field]])
      extra <- unique(raw[!is.na(raw) & !raw %in% names(choices)])
      data[[field]] <- factor(raw, levels = c(names(choices), extra), labels = c(unname(choices), extra))
      attr(data[[field]], "label") <- label
      attr(data[[field]], "r4vn_values") <- choices
    }
  }
  data
}

.r4vn_input_data <- function(x, labels = "factor") {
  if (is.data.frame(x)) return(x)
  if (is.character(x) && length(x) == 1L && file.exists(x)) return(opendata(x, labels = labels, active = FALSE, quiet = TRUE))
  stop("Input must be a data frame or an existing file path.", call. = FALSE)
}

.r4vn_source_name <- function(expr, value, index) {
  if (is.symbol(expr)) return(as.character(expr))
  if (is.character(value) && length(value) == 1L) return(basename(value))
  paste0("data", index)
}

.r4vn_cast_for_append <- function(columns, force = FALSE) {
  # Columns absent from a data frame are temporarily represented by an
  # all-missing logical vector. Such placeholders must not determine the
  # common type; otherwise a new character/factor column is seen as an
  # incompatible logical + character combination.
  placeholder <- vapply(columns, function(x) {
    is.logical(x) && all(is.na(x))
  }, logical(1))
  typed <- columns[!placeholder]
  if (!length(typed)) typed <- columns

  cls <- unique(vapply(typed, function(x) {
    if (is.factor(x)) "factor"
    else if (is.character(x)) "character"
    else if (is.double(x)) "double"
    else if (is.integer(x)) "integer"
    else if (is.logical(x)) "logical"
    else class(x)[1L]
  }, character(1)))

  if (length(cls) == 1L) return(cls)
  if (all(cls %in% c("logical", "integer"))) return("integer")
  if (all(cls %in% c("logical", "integer", "double"))) return("double")
  if (all(cls %in% c("factor", "character"))) return("factor")
  if (isTRUE(force)) return("character")

  stop(
    "Incompatible column types: ", paste(cls, collapse = ", "),
    ". Use `force = TRUE` to convert to character.",
    call. = FALSE
  )
}

.r4vn_bind_rows <- function(lst, force = FALSE) {
  all_names <- unique(unlist(lapply(lst, names), use.names = FALSE))
  for (i in seq_along(lst)) {
    miss <- setdiff(all_names, names(lst[[i]])); for (v in miss) lst[[i]][[v]] <- rep(NA, nrow(lst[[i]]))
    lst[[i]] <- lst[[i]][all_names]
  }
  meta <- lapply(all_names, function(v) {
    xs <- lapply(lst, `[[`, v)
    labs <- vapply(xs, function(x) { z <- attr(x, "label", exact = TRUE); if (is.null(z)) "" else as.character(z)[1L] }, character(1))
    maps <- lapply(xs, function(x) attr(x, "r4vn_values", exact = TRUE))
    list(label = labs[which(nzchar(labs))[1L]], values = maps[[which.max(lengths(maps))]])
  }); names(meta) <- all_names
  for (v in all_names) {
    xs <- lapply(lst, `[[`, v); type <- .r4vn_cast_for_append(xs, force)
    lev <- if (type == "factor") unique(unlist(lapply(xs, function(x) if (is.factor(x)) levels(x) else unique(as.character(x[!is.na(x)]))), use.names = FALSE)) else NULL
    for (i in seq_along(lst)) {
      x <- lst[[i]][[v]]
      lst[[i]][[v]] <- if (type == "integer") as.integer(x) else if (type == "double") as.numeric(x) else if (type == "character") as.character(x) else if (type == "factor") factor(as.character(x), levels = lev) else x
    }
  }
  out <- do.call(rbind, unname(lst)); rownames(out) <- NULL
  for (v in all_names) {
    if (length(meta[[v]]$label) && !is.na(meta[[v]]$label)) attr(out[[v]], "label") <- meta[[v]]$label
    if (!is.null(meta[[v]]$values)) attr(out[[v]], "r4vn_values") <- meta[[v]]$values
  }
  out
}

.r4vn_key <- function(data, by) {
  parts <- lapply(data[by], function(x) { z <- as.character(x); z[is.na(z)] <- "<NA>"; z })
  do.call(paste, c(parts, sep = "\u001f"))
}

.r4vn_check_merge_type <- function(master, using, by, type) {
  dm <- anyDuplicated(.r4vn_key(master, by)) > 0L; du <- anyDuplicated(.r4vn_key(using, by)) > 0L
  if (type == "1:1" && (dm || du)) stop("`type = \"1:1\"` requires unique keys in both data frames.", call. = FALSE)
  if (type == "1:m" && dm) stop("`type = \"1:m\"` requires unique keys in master data.", call. = FALSE)
  if (type == "m:1" && du) stop("`type = \"m:1\"` requires unique keys in using data.", call. = FALSE)
  invisible(TRUE)
}

.r4vn_coalesce <- function(master, using, replace = FALSE) {
  if (is.factor(master) || is.factor(using)) {
    a <- as.character(master); b <- as.character(using)
    take <- if (isTRUE(replace)) !is.na(b) else is.na(a) & !is.na(b)
    a[take] <- b[take]
    return(factor(a, levels = unique(c(if (is.factor(master)) levels(master) else a, if (is.factor(using)) levels(using) else b))))
  }
  out <- master; take <- if (isTRUE(replace)) !is.na(using) else is.na(out) & !is.na(using); out[take] <- using[take]; out
}
# Internal connector helpers for opendata().
# Adds KoboToolbox, Google Forms/Sheets, Microsoft Excel/Forms, and MySQL/MariaDB.
# Existing R4VN data-management helpers are intentionally not modified.

.r4vn_http_json <- function(url, token = NULL, auth = c("bearer", "token"), headers = NULL) {
  .r4vn_require_optional("curl", "to connect to web APIs")
  .r4vn_require_optional("jsonlite", "to parse web API responses")
  auth <- match.arg(auth)

  handle <- curl::new_handle()
  header_values <- character()
  if (!is.null(token) && nzchar(token)) {
    header_values["Authorization"] <- paste(if (auth == "bearer") "Bearer" else "Token", token)
  }
  if (!is.null(headers) && length(headers)) header_values <- c(header_values, headers)
  if (length(header_values)) {
    do.call(curl::handle_setheaders, c(list(handle = handle), as.list(header_values)))
  }

  response <- curl::curl_fetch_memory(url, handle = handle)
  text <- rawToChar(response$content)
  if (response$status_code < 200L || response$status_code >= 300L) {
    detail <- substr(gsub("[\r\n]+", " ", text), 1L, 500L)
    stop(
      "API returned HTTP status ", response$status_code,
      if (nzchar(detail)) paste0(": ", detail) else ".",
      call. = FALSE
    )
  }

  jsonlite::fromJSON(text, simplifyVector = FALSE)
}

.r4vn_urlencode <- function(x) utils::URLencode(as.character(x), reserved = TRUE)

.r4vn_api_scalar <- function(x) {
  if (is.null(x) || length(x) == 0L) return(NA)
  if (is.atomic(x) && length(x) == 1L) return(x)
  if (is.atomic(x)) return(paste(as.character(x), collapse = "; "))
  .r4vn_require_optional("jsonlite", "to preserve nested API values")
  jsonlite::toJSON(x, auto_unbox = TRUE, null = "null", na = "null")
}

.r4vn_records_df <- function(records, check.names = FALSE) {
  if (is.null(records) || !length(records)) return(data.frame())
  if (!is.list(records)) stop("API records are not in the expected list format.", call. = FALSE)

  all_names <- unique(unlist(lapply(records, names), use.names = FALSE))
  rows <- lapply(records, function(record) {
    out <- vector("list", length(all_names)); names(out) <- all_names
    for (nm in all_names) out[[nm]] <- .r4vn_api_scalar(record[[nm]])
    out
  })

  columns <- lapply(all_names, function(nm) {
    values <- lapply(rows, `[[`, nm)
    numeric_ok <- all(vapply(values, function(z) is.na(z) || is.numeric(z) || is.integer(z), logical(1)))
    logical_ok <- all(vapply(values, function(z) is.na(z) || is.logical(z), logical(1)))
    if (logical_ok) return(as.logical(unlist(values)))
    if (numeric_ok) return(as.numeric(unlist(values)))
    vapply(values, function(z) {
      if (length(z) == 0L || is.na(z)[1L]) NA_character_ else as.character(z)[1L]
    }, character(1))
  })
  names(columns) <- all_names
  as.data.frame(columns, stringsAsFactors = FALSE, check.names = check.names)
}

.r4vn_first_text <- function(x) {
  if (is.null(x) || !length(x)) return("")
  if (is.character(x)) return(as.character(x)[1L])
  if (is.list(x)) {
    values <- unlist(x, recursive = TRUE, use.names = FALSE)
    values <- values[!is.na(values) & nzchar(as.character(values))]
    if (length(values)) return(as.character(values)[1L])
  }
  as.character(x)[1L]
}

# -----------------------------------------------------------------------------
# KoboToolbox
# -----------------------------------------------------------------------------

.r4vn_kobo_project <- function(url = NULL, uid = NULL, server = NULL) {
  if (!is.null(url) && nzchar(url)) {
    if (is.null(server) || !nzchar(server)) {
      host <- sub("^(https?://[^/]+).*$", "\\1", url)
      if (grepl("^https?://", host)) server <- host
    }
    if (is.null(uid) || !nzchar(uid)) {
      m <- regexec("/forms/([^/?#]+)", url, perl = TRUE)
      hit <- regmatches(url, m)[[1L]]
      if (length(hit) >= 2L) uid <- hit[2L]
    }
  }
  if (is.null(server) || !nzchar(server)) server <- "https://kf.kobotoolbox.org"
  server <- sub("/+$", "", server)
  if (is.null(uid) || !nzchar(uid)) {
    stop("`uid` is required for KoboToolbox (or supply a Kobo project `url`).", call. = FALSE)
  }
  list(server = server, uid = uid)
}

.r4vn_kobo_metadata <- function(data, asset, labels = "factor") {
  content <- asset$content
  survey <- if (is.list(content)) content$survey else NULL
  choices <- if (is.list(content)) content$choices else NULL
  if (is.null(survey) || !length(survey)) return(data)

  choice_maps <- list()
  if (!is.null(choices) && length(choices)) {
    list_names <- unique(vapply(choices, function(z) {
      if (is.null(z$list_name)) "" else as.character(z$list_name)[1L]
    }, character(1)))
    list_names <- list_names[nzchar(list_names)]
    for (ln in list_names) {
      subset <- choices[vapply(choices, function(z) {
        identical(as.character(z$list_name)[1L], ln)
      }, logical(1))]
      codes <- vapply(subset, function(z) if (is.null(z$name)) "" else as.character(z$name)[1L], character(1))
      labs <- vapply(subset, function(z) .r4vn_first_text(z$label), character(1))
      keep <- nzchar(codes)
      map <- labs[keep]; names(map) <- codes[keep]
      choice_maps[[ln]] <- map
    }
  }

  for (q in survey) {
    nm <- if (is.null(q$name)) "" else as.character(q$name)[1L]
    if (!nzchar(nm)) next
    candidates <- c(nm, paste0("/", nm))
    exact <- candidates[candidates %in% names(data)]
    if (length(exact)) {
      v <- exact[1L]
    } else {
      suffix_hit <- names(data)[endsWith(names(data), paste0("/", nm))]
      v <- if (length(suffix_hit) == 1L) suffix_hit else NA_character_
    }
    if (is.na(v) || !length(v)) next

    lab <- .r4vn_first_text(q$label)
    if (nzchar(lab)) attr(data[[v]], "label") <- lab

    type <- if (is.null(q$type)) "" else as.character(q$type)[1L]
    list_name <- ""
    if (grepl("^select_(one|multiple)\\s+", type)) {
      list_name <- sub("^select_(one|multiple)\\s+", "", type)
    }
    if (!nzchar(list_name) && !is.null(q$select_from_list_name)) {
      list_name <- as.character(q$select_from_list_name)[1L]
    }
    map <- choice_maps[[list_name]]
    if (is.null(map) || !length(map)) next

    attr(data[[v]], "r4vn_values") <- map
    if (labels == "factor" && grepl("^select_one", type)) {
      raw <- as.character(data[[v]])
      extra <- unique(raw[!is.na(raw) & !raw %in% names(map)])
      data[[v]] <- factor(raw, levels = c(names(map), extra), labels = c(unname(map), extra))
      if (nzchar(lab)) attr(data[[v]], "label") <- lab
      attr(data[[v]], "r4vn_values") <- map
    }
  }
  data
}

.r4vn_open_kobo <- function(url = NULL, uid = NULL, server = NULL, token,
                            labels = "factor", page_size = 1000L,
                            check.names = FALSE) {
  if (is.null(token) || !nzchar(token)) stop("`token` is required for KoboToolbox.", call. = FALSE)
  project <- .r4vn_kobo_project(url = url, uid = uid, server = server)
  page_size <- as.integer(page_size)[1L]
  if (is.na(page_size) || page_size < 1L) page_size <- 1000L

  asset_url <- paste0(project$server, "/api/v2/assets/", .r4vn_urlencode(project$uid), "/")
  asset <- .r4vn_http_json(asset_url, token = token, auth = "token")

  next_url <- paste0(asset_url, "data/?limit=", page_size)
  records <- list()
  repeat {
    page <- .r4vn_http_json(next_url, token = token, auth = "token")
    if (!is.null(page$results) && length(page$results)) records <- c(records, page$results)
    next_url <- page[["next"]]
    if (is.null(next_url) || !length(next_url) || is.na(next_url)[1L] || !nzchar(as.character(next_url)[1L])) break
    next_url <- as.character(next_url)[1L]
  }

  data <- .r4vn_records_df(records, check.names = check.names)
  data <- .r4vn_kobo_metadata(data, asset, labels = labels)
  attr(data, "r4vn_source") <- paste0("KoboToolbox: ", project$server, " / ", project$uid)
  data
}

# -----------------------------------------------------------------------------
# Google Forms
# -----------------------------------------------------------------------------

.r4vn_google_form_id <- function(form = NULL, url = NULL) {
  if (!is.null(form) && nzchar(form)) return(as.character(form)[1L])
  if (!is.null(url) && nzchar(url)) {
    patterns <- c("/forms/d/e/([^/?#]+)", "/forms/d/([^/?#]+)")
    for (pat in patterns) {
      m <- regexec(pat, url, perl = TRUE)
      hit <- regmatches(url, m)[[1L]]
      if (length(hit) >= 2L) return(hit[2L])
    }
  }
  stop("`form` is required for Google Forms (or supply a Google Forms `url`).", call. = FALSE)
}

.r4vn_google_questions <- function(form_meta) {
  items <- form_meta$items
  out <- list()
  if (is.null(items)) return(out)

  add_question <- function(question, title, parent = NULL) {
    qid <- question$questionId
    if (is.null(qid) || !nzchar(as.character(qid)[1L])) return()
    label <- if (!is.null(parent) && nzchar(parent)) paste0(parent, ": ", title) else title
    choice <- question$choiceQuestion
    options <- NULL
    multiple <- FALSE
    if (!is.null(choice)) {
      options <- vapply(choice$options, function(z) {
        if (is.null(z$value)) "" else as.character(z$value)[1L]
      }, character(1))
      options <- options[nzchar(options)]
      multiple <- identical(choice$type, "CHECKBOX")
    }
    out[[as.character(qid)[1L]]] <<- list(label = label, options = options, multiple = multiple)
  }

  for (item in items) {
    title <- if (is.null(item$title)) "" else as.character(item$title)[1L]
    if (!is.null(item$questionItem$question)) add_question(item$questionItem$question, title)
    if (!is.null(item$questionGroupItem$questions)) {
      for (q in item$questionGroupItem$questions) {
        row_title <- if (!is.null(q$rowQuestion$title)) as.character(q$rowQuestion$title)[1L] else ""
        add_question(q, row_title, parent = title)
      }
    }
  }
  out
}

.r4vn_google_answer <- function(answer) {
  if (is.null(answer)) return(NA_character_)
  if (!is.null(answer$textAnswers$answers)) {
    values <- vapply(answer$textAnswers$answers, function(z) {
      if (is.null(z$value)) "" else as.character(z$value)[1L]
    }, character(1))
    values <- values[nzchar(values)]
    return(if (length(values)) paste(values, collapse = "; ") else NA_character_)
  }
  if (!is.null(answer$fileUploadAnswers$answers)) {
    values <- vapply(answer$fileUploadAnswers$answers, function(z) {
      if (!is.null(z$fileName) && nzchar(as.character(z$fileName)[1L])) as.character(z$fileName)[1L]
      else if (!is.null(z$fileId)) as.character(z$fileId)[1L] else ""
    }, character(1))
    values <- values[nzchar(values)]
    return(if (length(values)) paste(values, collapse = "; ") else NA_character_)
  }
  NA_character_
}

.r4vn_open_googleform <- function(form = NULL, url = NULL, access_token,
                                  labels = "factor", question_names = c("id", "title"),
                                  page_size = 5000L, check.names = FALSE) {
  if (is.null(access_token) || !nzchar(access_token)) {
    stop("`access_token` is required for direct Google Forms API access. Alternatively export responses to CSV/XLSX and use `opendata(file)`.", call. = FALSE)
  }
  question_names <- match.arg(question_names)
  form_id <- .r4vn_google_form_id(form = form, url = url)
  base <- paste0("https://forms.googleapis.com/v1/forms/", .r4vn_urlencode(form_id))
  meta <- .r4vn_http_json(base, token = access_token, auth = "bearer")
  questions <- .r4vn_google_questions(meta)

  page_size <- as.integer(page_size)[1L]
  if (is.na(page_size) || page_size < 1L) page_size <- 5000L
  page_size <- min(page_size, 5000L)

  responses <- list(); page_token <- NULL
  repeat {
    endpoint <- paste0(base, "/responses?pageSize=", page_size)
    if (!is.null(page_token)) endpoint <- paste0(endpoint, "&pageToken=", .r4vn_urlencode(page_token))
    page <- .r4vn_http_json(endpoint, token = access_token, auth = "bearer")
    if (!is.null(page$responses) && length(page$responses)) responses <- c(responses, page$responses)
    page_token <- page$nextPageToken
    if (is.null(page_token) || !length(page_token) || !nzchar(as.character(page_token)[1L])) break
    page_token <- as.character(page_token)[1L]
  }

  qids <- names(questions)
  if (question_names == "title") {
    base_names <- vapply(questions, function(z) if (nzchar(z$label)) z$label else "question", character(1))
    var_names <- make.names(base_names, unique = TRUE)
    names(var_names) <- qids
  } else {
    var_names <- qids; names(var_names) <- qids
  }

  rows <- lapply(responses, function(r) {
    ans <- rep(NA_character_, length(qids)); names(ans) <- unname(var_names[qids])
    if (!is.null(r$answers)) {
      for (qid in intersect(names(r$answers), qids)) {
        ans[[var_names[[qid]]]] <- .r4vn_google_answer(r$answers[[qid]])
      }
    }
    c(list(
      response_id = if (is.null(r$responseId)) NA_character_ else as.character(r$responseId)[1L],
      created_at = if (is.null(r$createTime)) NA_character_ else as.character(r$createTime)[1L],
      submitted_at = if (is.null(r$lastSubmittedTime)) NA_character_ else as.character(r$lastSubmittedTime)[1L],
      email = if (is.null(r$respondentEmail)) NA_character_ else as.character(r$respondentEmail)[1L],
      total_score = if (is.null(r$totalScore)) NA_real_ else as.numeric(r$totalScore)[1L]
    ), as.list(ans))
  })

  data <- if (length(rows)) {
    as.data.frame(
      do.call(rbind, lapply(rows, function(z) as.data.frame(z, stringsAsFactors = FALSE, check.names = FALSE))),
      stringsAsFactors = FALSE, check.names = check.names
    )
  } else {
    empty <- data.frame(
      response_id = character(), created_at = character(), submitted_at = character(),
      email = character(), total_score = numeric(), check.names = FALSE
    )
    for (nm in unname(var_names)) empty[[nm]] <- character()
    empty
  }

  if (nrow(data)) suppressWarnings(data$total_score <- as.numeric(data$total_score))

  for (qid in qids) {
    v <- var_names[[qid]]
    if (!v %in% names(data)) next
    info <- questions[[qid]]
    if (nzchar(info$label)) attr(data[[v]], "label") <- info$label
    if (!is.null(info$options) && length(info$options)) {
      attr(data[[v]], "r4vn_values") <- stats::setNames(info$options, info$options)
      if (labels == "factor" && !isTRUE(info$multiple)) {
        raw <- as.character(data[[v]])
        extra <- unique(raw[!is.na(raw) & !raw %in% info$options])
        data[[v]] <- factor(raw, levels = c(info$options, extra))
        if (nzchar(info$label)) attr(data[[v]], "label") <- info$label
        attr(data[[v]], "r4vn_values") <- stats::setNames(info$options, info$options)
      }
    }
  }

  attr(data, "r4vn_source") <- paste0("Google Forms: ", form_id)
  data
}

# -----------------------------------------------------------------------------
# Google Sheets
# -----------------------------------------------------------------------------

.r4vn_google_sheet_id <- function(url = NULL, sheet_id = NULL) {
  if (!is.null(sheet_id) && nzchar(sheet_id)) return(as.character(sheet_id)[1L])
  if (!is.null(url) && nzchar(url)) {
    m <- regexec("/spreadsheets/d/([^/?#]+)", url, perl = TRUE)
    hit <- regmatches(url, m)[[1L]]
    if (length(hit) >= 2L) return(hit[2L])
  }
  stop("`sheet_id` is required for Google Sheets (or supply a Google Sheets `url`).", call. = FALSE)
}

.r4vn_google_gid <- function(url = NULL) {
  if (is.null(url) || !nzchar(url)) return(NULL)
  m <- regexec("(?:[?#&]gid=)([0-9]+)", url, perl = TRUE)
  hit <- regmatches(url, m)[[1L]]
  if (length(hit) >= 2L) hit[2L] else NULL
}

.r4vn_matrix_df <- function(values, header = TRUE, check.names = FALSE) {
  if (is.null(values) || !length(values)) return(data.frame())
  width <- max(vapply(values, length, integer(1)))
  mat <- do.call(rbind, lapply(values, function(z) {
    c(unlist(z, use.names = FALSE), rep(NA, width - length(z)))
  }))
  if (isTRUE(header)) {
    nm <- as.character(mat[1L, ])
    empty <- is.na(nm) | !nzchar(nm)
    nm[empty] <- paste0("V", which(empty))
    out <- as.data.frame(mat[-1L, , drop = FALSE], stringsAsFactors = FALSE, check.names = check.names)
    names(out) <- if (check.names) make.names(nm, unique = TRUE) else make.unique(nm)
  } else {
    out <- as.data.frame(mat, stringsAsFactors = FALSE, check.names = check.names)
    names(out) <- paste0("V", seq_len(ncol(out)))
  }
  rownames(out) <- NULL
  out
}

.r4vn_open_gsheet <- function(url = NULL, sheet_id = NULL, access_token = NULL,
                              range = NULL, sheet = 1, header = TRUE,
                              check.names = FALSE, quiet = FALSE,
                              na = c("", "NA"), encoding = "UTF-8") {
  id <- .r4vn_google_sheet_id(url = url, sheet_id = sheet_id)

  if (!is.null(access_token) && nzchar(access_token)) {
    # Official Google Sheets API for private/authenticated sheets.
    if (is.null(range)) {
      if (is.character(sheet) && nzchar(sheet)) {
        range <- paste0("'", gsub("'", "''", sheet, fixed = TRUE), "'!A:ZZZ")
      } else {
        range <- "A:ZZZ"
      }
    }
    endpoint <- paste0(
      "https://sheets.googleapis.com/v4/spreadsheets/", .r4vn_urlencode(id),
      "/values/", .r4vn_urlencode(range)
    )
    obj <- .r4vn_http_json(endpoint, token = access_token, auth = "bearer")
    data <- .r4vn_matrix_df(obj$values, header = header, check.names = check.names)
  } else {
    # Public / Anyone-with-link sheet. gviz supports a named tab and range.
    if (is.character(sheet) && length(sheet) == 1L && nzchar(sheet) && !identical(sheet, "1")) {
      export <- paste0(
        "https://docs.google.com/spreadsheets/d/", id,
        "/gviz/tq?tqx=out:csv&sheet=", .r4vn_urlencode(sheet)
      )
      if (!is.null(range) && nzchar(range)) export <- paste0(export, "&range=", .r4vn_urlencode(range))
    } else {
      gid <- .r4vn_google_gid(url)
      if (is.null(gid)) gid <- "0"
      export <- paste0(
        "https://docs.google.com/spreadsheets/d/", id,
        "/export?format=csv&gid=", gid
      )
    }

    tmp <- tempfile(fileext = ".csv")
    on.exit(unlink(tmp), add = TRUE)
    status <- try(utils::download.file(export, tmp, mode = "wb", quiet = quiet), silent = TRUE)
    if (inherits(status, "try-error") || !file.exists(tmp) || file.info(tmp)$size == 0L) {
      stop(
        "Could not read the Google Sheet. For a no-login share link, set General access to `Anyone with the link` (Viewer), or provide `access_token` for a private sheet.",
        call. = FALSE
      )
    }
    data <- utils::read.csv(
      tmp, header = header, na.strings = na, fileEncoding = encoding,
      stringsAsFactors = FALSE, check.names = check.names
    )
  }

  attr(data, "r4vn_source") <- paste0("Google Sheets: ", id)
  data
}

# -----------------------------------------------------------------------------
# Microsoft Excel / Microsoft Forms linked workbook
# -----------------------------------------------------------------------------

.r4vn_graph_base <- function(drive_id = NULL, item_id) {
  if (is.null(item_id) || !nzchar(item_id)) {
    stop("`item_id` is required for Microsoft Excel/Forms.", call. = FALSE)
  }
  if (is.null(drive_id) || !nzchar(drive_id)) {
    paste0("https://graph.microsoft.com/v1.0/me/drive/items/", .r4vn_urlencode(item_id))
  } else {
    paste0(
      "https://graph.microsoft.com/v1.0/drives/", .r4vn_urlencode(drive_id),
      "/items/", .r4vn_urlencode(item_id)
    )
  }
}

.r4vn_open_msexcel <- function(access_token, drive_id = NULL, item_id,
                               table = NULL, sheet = NULL, range = NULL,
                               header = TRUE, page_size = 5000L,
                               check.names = FALSE) {
  if (is.null(access_token) || !nzchar(access_token)) {
    stop("`access_token` is required for Microsoft Graph. Alternatively export Forms responses to XLSX/CSV and use `opendata(file)`.", call. = FALSE)
  }
  base <- .r4vn_graph_base(drive_id = drive_id, item_id = item_id)

  if (!is.null(table) && nzchar(table)) {
    table_enc <- .r4vn_urlencode(table)
    hdr <- .r4vn_http_json(
      paste0(base, "/workbook/tables/", table_enc, "/headerRowRange"),
      token = access_token, auth = "bearer"
    )
    headers <- if (!is.null(hdr$values) && length(hdr$values)) {
      unlist(hdr$values[[1L]], use.names = FALSE)
    } else NULL

    rows <- list(); skip <- 0L
    page_size <- max(1L, as.integer(page_size)[1L])
    repeat {
      endpoint <- paste0(
        base, "/workbook/tables/", table_enc,
        "/rows?$top=", page_size, "&$skip=", skip
      )
      obj <- .r4vn_http_json(endpoint, token = access_token, auth = "bearer")
      batch <- obj$value
      if (is.null(batch) || !length(batch)) break
      for (r in batch) if (!is.null(r$values) && length(r$values)) rows <- c(rows, r$values)
      if (length(batch) < page_size) break
      skip <- skip + length(batch)
    }
    values <- rows
    if (isTRUE(header) && !is.null(headers)) values <- c(list(headers), values)
    data <- .r4vn_matrix_df(values, header = header, check.names = check.names)
  } else {
    if (is.null(sheet) || (is.numeric(sheet) && identical(as.integer(sheet)[1L], 1L))) {
      ws <- .r4vn_http_json(paste0(base, "/workbook/worksheets"), token = access_token, auth = "bearer")
      if (is.null(ws$value) || !length(ws$value)) stop("The workbook contains no worksheets.", call. = FALSE)
      sheet <- as.character(ws$value[[1L]]$name)[1L]
    }
    sheet_enc <- .r4vn_urlencode(as.character(sheet)[1L])
    endpoint <- if (is.null(range) || !nzchar(range)) {
      paste0(base, "/workbook/worksheets/", sheet_enc, "/usedRange(valuesOnly=true)")
    } else {
      paste0(base, "/workbook/worksheets/", sheet_enc, "/range(address='", .r4vn_urlencode(range), "')")
    }
    obj <- .r4vn_http_json(endpoint, token = access_token, auth = "bearer")
    data <- .r4vn_matrix_df(obj$values, header = header, check.names = check.names)
  }

  attr(data, "r4vn_source") <- paste0("Microsoft Excel/Forms via Graph: ", item_id)
  data
}

# -----------------------------------------------------------------------------
# MySQL / MariaDB
# -----------------------------------------------------------------------------

.r4vn_mysql_readonly_query <- function(query) {
  if (is.null(query) || length(query) != 1L || !nzchar(trimws(query))) {
    stop("`query` must be one non-empty SQL query.", call. = FALSE)
  }

  q <- trimws(as.character(query)[1L])
  # Remove leading SQL comments for command detection.
  repeat {
    old <- q
    q <- sub("^--[^\n]*(\n|$)", "", q, perl = TRUE)
    q <- sub("^/\\*.*?\\*/\\s*", "", q, perl = TRUE)
    q <- trimws(q)
    if (identical(old, q)) break
  }

  low <- tolower(q)
  if (!grepl("^(select|show|describe|desc|explain|with)\\b", low, perl = TRUE)) {
    stop("For safety, `opendata(api = \"mysql\")` accepts read-only SQL only (SELECT/SHOW/DESCRIBE/EXPLAIN/WITH SELECT).", call. = FALSE)
  }

  # Reject multiple SQL statements.
  no_last_semicolon <- sub(";\\s*$", "", q, perl = TRUE)
  if (grepl(";", no_last_semicolon, fixed = TRUE)) {
    stop("Multiple SQL statements are not allowed in `query`.", call. = FALSE)
  }

  # WITH can also prefix modifying statements in modern MySQL, so reject obvious writes.
  dangerous <- paste0(
    "\\b(insert|update|delete|replace|drop|alter|create|truncate|grant|revoke|",
    "call|rename|lock|unlock|load\\s+data|set\\s+password)\\b"
  )
  if (grepl(dangerous, low, perl = TRUE)) {
    stop("Write/DDL SQL is not allowed in `opendata()`.", call. = FALSE)
  }

  q
}

.r4vn_open_mysql <- function(host = "localhost", port = 3306L,
                             dbname, user = NULL, password = NULL,
                             table = NULL, query = NULL,
                             ssl_ca = NULL, ssl_cert = NULL, ssl_key = NULL,
                             timeout = 10, bigint = "integer64",
                             mysql = TRUE, check.names = FALSE) {
  .r4vn_require_optional("DBI", "to connect to MySQL/MariaDB")
  .r4vn_require_optional("RMariaDB", "to connect to MySQL/MariaDB")

  if (is.null(dbname) || !nzchar(dbname)) stop("`dbname` (or `database`) is required for MySQL/MariaDB.", call. = FALSE)
  if ((is.null(table) || !nzchar(as.character(table)[1L])) &&
      (is.null(query) || !nzchar(trimws(as.character(query)[1L])))) {
    stop("Supply either `table` or a read-only `query` for MySQL/MariaDB.", call. = FALSE)
  }
  if (!is.null(table) && nzchar(as.character(table)[1L]) &&
      !is.null(query) && nzchar(trimws(as.character(query)[1L]))) {
    stop("Use either `table` or `query`, not both.", call. = FALSE)
  }

  port <- as.integer(port)[1L]
  if (is.na(port) || port < 1L || port > 65535L) stop("`port` must be between 1 and 65535.", call. = FALSE)

  connect_args <- list(
    drv = RMariaDB::MariaDB(),
    dbname = dbname,
    username = user,
    password = password,
    host = host,
    port = port,
    timeout = timeout,
    bigint = bigint,
    mysql = isTRUE(mysql)
  )
  if (!is.null(ssl_key) && nzchar(ssl_key)) connect_args$ssl.key <- ssl_key
  if (!is.null(ssl_cert) && nzchar(ssl_cert)) connect_args$ssl.cert <- ssl_cert
  if (!is.null(ssl_ca) && nzchar(ssl_ca)) connect_args$ssl.ca <- ssl_ca

  con <- tryCatch(
    do.call(DBI::dbConnect, connect_args),
    error = function(e) {
      stop("Could not connect to MySQL/MariaDB: ", conditionMessage(e), call. = FALSE)
    }
  )
  on.exit(try(DBI::dbDisconnect(con), silent = TRUE), add = TRUE)

  data <- if (!is.null(query) && nzchar(trimws(as.character(query)[1L]))) {
    q <- .r4vn_mysql_readonly_query(query)
    tryCatch(
      DBI::dbGetQuery(con, q),
      error = function(e) stop("MySQL/MariaDB query failed: ", conditionMessage(e), call. = FALSE)
    )
  } else {
    table <- as.character(table)[1L]
    if (!DBI::dbExistsTable(con, table)) {
      stop("Table `", table, "` was not found in database `", dbname, "`.", call. = FALSE)
    }
    tryCatch(
      DBI::dbReadTable(con, table),
      error = function(e) stop("Could not read MySQL/MariaDB table: ", conditionMessage(e), call. = FALSE)
    )
  }

  data <- as.data.frame(data, check.names = check.names, stringsAsFactors = FALSE)
  attr(data, "r4vn_source") <- paste0(
    if (isTRUE(mysql)) "MySQL: " else "MariaDB: ", host, ":", port, "/", dbname,
    if (!is.null(table) && nzchar(as.character(table)[1L])) paste0("/", table) else " [query]"
  )
  data
}
#' Open data from files, research platforms, online forms, and databases
#'
#' Reads local/remote files and connects to supported research data sources.
#' Existing file and REDCap behavior is retained. Additional connectors support
#' KoboToolbox, Google Forms, Google Sheets, Microsoft Forms/Excel, and
#' MySQL/MariaDB.
#'
#' @param file File path or web URL. A bare file name is first resolved in the
#'   current working directory and, when not found there, in R4VN's bundled
#'   `inst/extdata` examples. Thus `opendata("ivf_v3_vi.dta")` opens the
#'   example Stata file shipped with R4VN. For Google Forms or Microsoft Forms
#'   exports, this may be the exported CSV/XLSX file. Omit when a direct
#'   API/database connector is used.
#' @param api Optional source name: `"redcap"`, `"kobo"`, `"googleform"`,
#'   `"gsheet"`, `"msexcel"`, `"msforms"`, `"mysql"`, or `"mariadb"`.
#'   Common aliases are accepted.
#' @param url API/project/form/sheet URL when applicable.
#' @param token REDCap or KoboToolbox API token. For Google/Microsoft, use
#'   `access_token`; `token` is also accepted as a fallback.
#' @param vars Optional variables to retain.
#' @param obs Optional observations to retain. `missing(x)` is supported.
#' @param active Logical; also place a working copy in active memory.
#' @param labels How imported value labels are handled: `"factor"`,
#'   `"labelled"`, or `"numeric"`.
#' @param header Logical; first text/spreadsheet row contains names.
#' @param sep Text-file delimiter. Defaults from extension.
#' @param sheet Excel/online workbook sheet name or number.
#' @param range Excel/online workbook cell range such as `"A1:H500"`.
#' @param skip Number of rows to skip for local files.
#' @param na Strings interpreted as missing.
#' @param encoding Text encoding.
#' @param check.names Logical; make names syntactically valid.
#' @param records,fields,forms,events Optional REDCap filters.
#' @param uid KoboToolbox asset UID. May be inferred from a Kobo project URL.
#' @param server KoboToolbox server. Defaults to the Global server and may be
#'   inferred from `url`.
#' @param form Google Forms form ID. May be inferred from a compatible form URL.
#' @param access_token OAuth bearer token for Google or Microsoft APIs.
#' @param question_names Google Forms variable naming: stable question `"id"`
#'   (default) or sanitized question `"title"`.
#' @param sheet_id Google Sheets spreadsheet ID. May be inferred from `url`.
#' @param drive_id,item_id Microsoft Graph drive/item identifiers for the Excel
#'   workbook containing Microsoft Forms responses.
#' @param table Microsoft Excel table name, or MySQL/MariaDB table name.
#' @param page_size Number of records requested per API page.
#' @param host MySQL/MariaDB server host.
#' @param port MySQL/MariaDB TCP port, usually 3306.
#' @param dbname,database MySQL/MariaDB database name. `database` is a friendly
#'   alias of `dbname`.
#' @param user,password MySQL/MariaDB credentials. A read-only database account
#'   is strongly recommended.
#' @param query Optional read-only SQL query. Use this instead of `table` for
#'   server-side filtering. Write/DDL statements are rejected.
#' @param ssl_ca,ssl_cert,ssl_key Optional SSL CA/certificate/key paths for
#'   MySQL/MariaDB.
#' @param db_timeout Database connection timeout in seconds.
#' @param bigint How 64-bit database integers are returned; passed to RMariaDB.
#' @param quiet Logical; suppress summary messages.
#' @param ... Additional arguments for the existing format-specific local reader.
#'
#' @details
#' Existing local-file and REDCap behavior is unchanged. When `file` is a bare
#' file name that does not exist in the current working directory, `opendata()`
#' also looks in the package's bundled `extdata` directory. This makes the
#' teaching dataset available simply as `opendata("ivf_v3_vi.dta")` after
#' R4VN is installed.
#'
#' KoboToolbox uses API v2 and Token authentication. Google Forms direct access
#' uses the official Forms API and OAuth. Google Sheets public share links can be
#' read without OAuth when the sheet is accessible to anyone with the link;
#' private sheets can be read with an OAuth access token.
#'
#' Google Forms and Microsoft Forms response files exported to CSV/XLSX can be
#' opened directly with `opendata(file)`. `api = "googleform"` or
#' `api = "msforms"` may also be supplied together with `file` as a friendly
#' alias; in that case the normal file reader is used.
#'
#' Microsoft Forms direct response access is handled through its linked Excel
#' workbook via Microsoft Graph. MySQL/MariaDB uses DBI + RMariaDB and closes the
#' database connection automatically before returning.
#'
#' @return A data frame.
#' @export
#'
#' @examples
#' # Bundled R4VN teaching dataset (Stata format).
#' if (requireNamespace("haven", quietly = TRUE) ||
#'     requireNamespace("readstata13", quietly = TRUE)) {
#'   ivf <- opendata("ivf_v3_vi.dta", quiet = TRUE)
#'   head(ivf)
#' }
#'
#' \dontrun{
#' # Existing REDCap behavior
#' redcap <- opendata(
#'   api = "redcap",
#'   url = "https://example.org/api/",
#'   token = "REDCAP_TOKEN",
#'   active = TRUE
#' )
#'
#' # KoboToolbox
#' kobo <- opendata(
#'   api = "kobo",
#'   uid = "aBcDeFg123",
#'   token = "KOBO_TOKEN",
#'   active = TRUE
#' )
#'
#' # Public Google Sheet using only a share link
#' gsheet <- opendata(
#'   api = "gsheet",
#'   url = "https://docs.google.com/spreadsheets/d/SPREADSHEET_ID/edit?gid=0",
#'   active = TRUE
#' )
#'
#' # Named tab and range from a public Google Sheet
#' gsheet2 <- opendata(
#'   api = "gsheet",
#'   url = "https://docs.google.com/spreadsheets/d/SPREADSHEET_ID/edit",
#'   sheet = "Responses",
#'   range = "A1:H500"
#' )
#'
#' # Google Forms / Microsoft Forms: easiest route after exporting responses
#' gform_export <- opendata("google-form-responses.xlsx")
#' msform_export <- opendata("microsoft-form-responses.xlsx")
#'
#' # Direct Google Forms API (OAuth token required)
#' gform <- opendata(
#'   api = "googleform",
#'   form = "FORM_ID",
#'   access_token = "GOOGLE_OAUTH_ACCESS_TOKEN"
#' )
#'
#' # Microsoft Forms linked Excel workbook via Microsoft Graph
#' msform <- opendata(
#'   api = "msforms",
#'   item_id = "WORKBOOK_ITEM_ID",
#'   access_token = "MS_GRAPH_ACCESS_TOKEN"
#' )
#'
#' # MySQL table
#' mysql_data <- opendata(
#'   api = "mysql",
#'   host = "db.example.org",
#'   dbname = "research",
#'   user = "reader",
#'   password = "PASSWORD",
#'   table = "participants"
#' )
#'
#' # MySQL read-only query
#' mysql_subset <- opendata(
#'   api = "mysql",
#'   host = "db.example.org",
#'   database = "research",
#'   user = "reader",
#'   password = "PASSWORD",
#'   query = "SELECT id, age, sex FROM participants WHERE age >= 18"
#' )
#' }
opendata <- function(file = NULL, api = NULL, url = NULL, token = NULL,
                     vars = NULL, obs = NULL, active = FALSE,
                     labels = c("factor", "labelled", "numeric"),
                     header = TRUE, sep = NULL, sheet = 1, range = NULL,
                     skip = 0, na = c("", "NA"), encoding = "UTF-8",
                     check.names = FALSE, records = NULL, fields = NULL,
                     forms = NULL, events = NULL, quiet = FALSE,
                     uid = NULL, server = NULL, form = NULL,
                     access_token = NULL, question_names = c("id", "title"),
                     sheet_id = NULL, drive_id = NULL, item_id = NULL,
                     table = NULL, page_size = 1000L,
                     host = "localhost", port = 3306L,
                     dbname = NULL, database = NULL,
                     user = NULL, password = NULL, query = NULL,
                     ssl_ca = NULL, ssl_cert = NULL, ssl_key = NULL,
                     db_timeout = 10, bigint = "integer64", ...) {
  env <- parent.frame()
  labels <- match.arg(labels)
  question_names <- match.arg(question_names)
  vars_expr <- if (missing(vars)) NULL else substitute(vars)
  obs_expr <- if (missing(obs)) NULL else substitute(obs)

  # Normalize source name first. Exported Google/MS Forms files intentionally
  # fall back to the existing local/URL file reader below.
  if (!is.null(api)) {
    api <- tolower(gsub("[-_ ]", "", as.character(api)[1L]))
    api <- switch(api,
      redcap = "redcap",
      kobo = "kobo", kobotoolbox = "kobo",
      google = "googleform", googleform = "googleform", googleforms = "googleform", gform = "googleform",
      gsheet = "gsheet", googlesheet = "gsheet", googlesheets = "gsheet",
      msexcel = "msexcel", microsoft = "msexcel", microsoftexcel = "msexcel",
      msforms = "msforms", microsoftforms = "msforms",
      mysql = "mysql",
      mariadb = "mariadb",
      stop(
        "Unsupported API. Use redcap, kobo, googleform, gsheet, msexcel, msforms, mysql, or mariadb.",
        call. = FALSE
      )
    )

    if (api %in% c("googleform", "msforms") &&
        !is.null(file) && length(file) == 1L && nzchar(file)) {
      if (!isTRUE(quiet)) {
        message(
          if (api == "googleform") "Opening exported Google Forms response file."
          else "Opening exported Microsoft Forms response file."
        )
      }
      api <- NULL
    }
  }

  if (!is.null(api)) {
    if (api == "redcap") {
      # Existing REDCap branch intentionally unchanged.
      if (is.null(url) || !nzchar(url)) stop("`url` is required.", call. = FALSE)
      if (is.null(token) || !nzchar(token)) stop("`token` is required.", call. = FALSE)
      rec_form <- list(
        content = "record", format = "csv", type = "flat",
        rawOrLabel = "raw", rawOrLabelHeaders = "raw",
        exportCheckboxLabel = "false", returnFormat = "csv"
      )
      if (!is.null(records)) rec_form$records <- paste(records, collapse = ",")
      if (!is.null(fields)) rec_form$fields <- paste(fields, collapse = ",")
      if (!is.null(forms)) rec_form$forms <- paste(forms, collapse = ",")
      if (!is.null(events)) rec_form$events <- paste(events, collapse = ",")
      record_text <- .r4vn_redcap_post(url, token, rec_form)
      metadata_text <- .r4vn_redcap_post(
        url, token,
        list(content = "metadata", format = "csv", returnFormat = "csv")
      )
      data <- .r4vn_read_csv_text(record_text, na, encoding)
      metadata <- .r4vn_read_csv_text(metadata_text, character(), encoding)
      data <- .r4vn_apply_redcap_metadata(data, metadata, labels)
      source <- paste0("REDCap: ", url)

    } else if (api == "kobo") {
      data <- .r4vn_open_kobo(
        url = url, uid = uid, server = server, token = token,
        labels = labels, page_size = page_size,
        check.names = check.names
      )
      source <- attr(data, "r4vn_source", exact = TRUE)

    } else if (api == "googleform") {
      credential <- if (!is.null(access_token) && nzchar(access_token)) access_token else token
      data <- .r4vn_open_googleform(
        form = form, url = url, access_token = credential,
        labels = labels, question_names = question_names,
        page_size = page_size, check.names = check.names
      )
      source <- attr(data, "r4vn_source", exact = TRUE)

    } else if (api == "gsheet") {
      credential <- if (!is.null(access_token) && nzchar(access_token)) access_token else token
      data <- .r4vn_open_gsheet(
        url = url, sheet_id = sheet_id,
        access_token = credential, range = range,
        sheet = sheet, header = header,
        check.names = check.names, quiet = quiet,
        na = na, encoding = encoding
      )
      source <- attr(data, "r4vn_source", exact = TRUE)

    } else if (api %in% c("msexcel", "msforms")) {
      credential <- if (!is.null(access_token) && nzchar(access_token)) access_token else token
      if (api == "msforms" && !isTRUE(quiet)) {
        message("Microsoft Forms responses are being read from the linked Excel workbook via Microsoft Graph.")
      }
      data <- .r4vn_open_msexcel(
        access_token = credential, drive_id = drive_id,
        item_id = item_id, table = table, sheet = sheet,
        range = range, header = header,
        page_size = page_size, check.names = check.names
      )
      source <- attr(data, "r4vn_source", exact = TRUE)

    } else if (api %in% c("mysql", "mariadb")) {
      dbname_use <- if (!is.null(dbname) && nzchar(dbname)) dbname else database
      data <- .r4vn_open_mysql(
        host = host, port = port, dbname = dbname_use,
        user = user, password = password,
        table = table, query = query,
        ssl_ca = ssl_ca, ssl_cert = ssl_cert, ssl_key = ssl_key,
        timeout = db_timeout, bigint = bigint,
        mysql = identical(api, "mysql"),
        check.names = check.names
      )
      source <- attr(data, "r4vn_source", exact = TRUE)
    }

  } else {
    # Existing local/URL import behavior below is intentionally unchanged.
    if (is.null(file) || length(file) != 1L || !nzchar(file)) {
      stop("Supply `file` or `api`.", call. = FALSE)
    }
    source <- file
    local <- file
    temporary <- FALSE

    # Friendly bundled-example lookup: if a simple local name is not found,
    # try the file distributed in R4VN/inst/extdata. This keeps ordinary local
    # paths and URLs unchanged while allowing, for example,
    # opendata("ivf_v3_vi.dta").
    bare_file <- !grepl("[/\\\\]", file)
    if (!file.exists(local) && isTRUE(bare_file) &&
        !grepl("^https?://", file, ignore.case = TRUE)) {
      package_file <- system.file(
        "extdata", basename(file), package = "R4VN"
      )
      if (nzchar(package_file) && file.exists(package_file)) {
        local <- package_file
        source <- paste0("R4VN example data: ", basename(file))
      }
    }

    if (grepl("^https?://", file, ignore.case = TRUE)) {
      ext0 <- .r4vn_ext(file)
      local <- tempfile(fileext = if (nzchar(ext0)) paste0(".", ext0) else "")
      utils::download.file(file, local, mode = "wb", quiet = quiet)
      temporary <- TRUE
      on.exit(if (temporary && file.exists(local)) unlink(local), add = TRUE)
    }

    if (!file.exists(local)) stop("File not found: ", file, call. = FALSE)
    ext <- .r4vn_ext(local)

    if (ext %in% c("csv", "tsv", "txt")) {
      delimiter <- if (is.null(sep)) if (ext == "csv") "," else "\t" else sep
      data <- utils::read.table(
        local, header = header, sep = delimiter, quote = "\"", dec = ".",
        na.strings = na, fileEncoding = encoding,
        stringsAsFactors = FALSE, check.names = check.names,
        comment.char = "", skip = skip, ...
      )
    } else if (ext %in% c("xlsx", "xls")) {
      .r4vn_require_optional("readxl", "to read Excel files")
      data <- as.data.frame(
        readxl::read_excel(
          local, sheet = sheet, range = range,
          col_names = header, skip = skip, na = na, ...
        ),
        check.names = check.names
      )
    } else if (ext == "dta") {
      data <- .r4vn_read_stata(local, labels = labels, encoding = encoding, check.names = check.names, dots = list(...), quiet = quiet)
    } else if (ext == "sav") {
      data <- .r4vn_read_spss(local, labels = labels, encoding = encoding, check.names = check.names, dots = list(...), quiet = quiet)
    } else if (ext %in% c("sas7bdat", "xpt")) {
      .r4vn_require_optional("haven", "to read SAS files")
      data <- if (ext == "xpt") haven::read_xpt(local, ...) else haven::read_sas(local, ...)
      data <- .r4vn_process_labels(as.data.frame(data, check.names = check.names), labels)
    } else if (ext == "rds") {
      data <- readRDS(local)
      if (!is.data.frame(data)) stop("RDS object is not a data frame.", call. = FALSE)
    } else if (ext %in% c("rda", "rdata")) {
      e <- new.env(parent = emptyenv())
      objects <- load(local, envir = e)
      frames <- objects[vapply(objects, function(x) is.data.frame(e[[x]]), logical(1))]
      if (length(frames) != 1L) {
        stop("RData/RDA must contain exactly one data frame.", call. = FALSE)
      }
      data <- e[[frames]]
    } else if (ext == "json") {
      .r4vn_require_optional("jsonlite", "to read JSON files")
      data <- as.data.frame(jsonlite::fromJSON(local, flatten = TRUE, ...), check.names = check.names)
    } else if (ext == "parquet") {
      .r4vn_require_optional("arrow", "to read Parquet files")
      data <- as.data.frame(arrow::read_parquet(local, ...), check.names = check.names)
    } else {
      stop("Unsupported file extension: .", ext, call. = FALSE)
    }
  }

  data <- .r4vn_subset(data, vars_expr, obs_expr, env)
  if (isTRUE(active)) {
    .r4vn_set_active(
      data,
      name = if (is.null(api)) basename(file) else api,
      source = source,
      quiet = quiet
    )
  } else if (!isTRUE(quiet)) {
    message("Opened ", nrow(data), " observations and ", ncol(data), " variables.")
  }
  data
}

# ----------------------------------------------------------------------------
# Consolidated from: savedata.R
# ----------------------------------------------------------------------------
#' Save data according to file extension
#'
#' Saves active data or an explicitly supplied data frame. Variables and
#' observations can be selected without changing the source data.
#'
#' @param data Data frame, or output path when saving active data.
#' @param file Output path. Omit when the first argument is the path.
#' @param vars Optional variables to save.
#' @param obs Optional observations to save. `missing(x)` is supported.
#' @param sheet Excel sheet name.
#' @param header Logical; write variable names for text files.
#' @param sep Text-file delimiter. Defaults from extension.
#' @param na Missing-value text for delimited files.
#' @param encoding Text encoding.
#' @param replace Logical; overwrite an existing file.
#' @param quiet Logical; suppress summary messages.
#' @param ... Additional writer arguments.
#'
#' @details
#' Use `savedata("file.csv")` for active data, or
#' `savedata(data, "file.csv")` for an explicit data frame.
#'
#' @return The normalized saved path invisibly.
#' @export
#'
#' @examples
#' d <- datasets::iris
#' usedf(d, quiet = TRUE)
#'
#' # Base-R formats: short examples run during R CMD check.
#' f_csv <- tempfile(fileext = ".csv")
#' f_sub <- tempfile(fileext = ".csv")
#' f_rds <- tempfile(fileext = ".rds")
#'
#' savedata(f_csv, quiet = TRUE)
#' savedata(
#'   f_sub,
#'   vars = vars(Sepal.Length, Species),
#'   obs = Species == "setosa",
#'   quiet = TRUE
#' )
#' savedata(d, f_rds, quiet = TRUE)
#' unlink(c(f_csv, f_sub, f_rds))
#' usedf(clear = TRUE, quiet = TRUE)
#'
#' # Optional formats are guarded because their writers are in Suggests.
#' if (requireNamespace("writexl", quietly = TRUE) ||
#'     requireNamespace("openxlsx", quietly = TRUE)) {
#'   f <- tempfile(fileext = ".xlsx")
#'   savedata(d, f, sheet = "Data", quiet = TRUE)
#'   unlink(f)
#' }
#'
#' if (requireNamespace("haven", quietly = TRUE)) {
#'   # Stata/SPSS impose variable-name rules. Use portable names here.
#'   d_haven <- data.frame(
#'     sepal_length = d$Sepal.Length,
#'     sepal_width = d$Sepal.Width,
#'     petal_length = d$Petal.Length,
#'     petal_width = d$Petal.Width,
#'     species = as.character(d$Species),
#'     stringsAsFactors = FALSE
#'   )
#'   f_dta <- tempfile(fileext = ".dta")
#'   f_sav <- tempfile(fileext = ".sav")
#'   savedata(d_haven, f_dta, quiet = TRUE)
#'   savedata(d_haven, f_sav, quiet = TRUE)
#'   unlink(c(f_dta, f_sav))
#' }
#'
#' if (requireNamespace("jsonlite", quietly = TRUE)) {
#'   f <- tempfile(fileext = ".json")
#'   savedata(d, f, quiet = TRUE)
#'   unlink(f)
#' }
#'
#' \donttest{
#' if (requireNamespace("arrow", quietly = TRUE)) {
#'   f <- tempfile(fileext = ".parquet")
#'   savedata(d, f, quiet = TRUE)
#'   unlink(f)
#' }
#' }
savedata <- function(data = NULL, file = NULL, vars = NULL, obs = NULL,
                     sheet = "Data", header = TRUE, sep = NULL, na = "",
                     encoding = "UTF-8", replace = FALSE, quiet = FALSE, ...) {
  env <- parent.frame()
  if (is.character(data) && length(data) == 1L && is.null(file)) {
    file <- data; data <- .r4vn_get_active()
  } else if (is.null(data)) data <- .r4vn_get_active()
  if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)
  if (is.null(file) || length(file) != 1L || !nzchar(file)) stop("`file` is required.", call. = FALSE)
  vars_expr <- if (missing(vars)) NULL else substitute(vars)
  obs_expr <- if (missing(obs)) NULL else substitute(obs)
  out <- .r4vn_subset(data, vars_expr, obs_expr, env)
  if (file.exists(file) && !isTRUE(replace)) stop("File exists. Use `replace = TRUE`.", call. = FALSE)
  dir.create(dirname(normalizePath(file, winslash = "/", mustWork = FALSE)), recursive = TRUE, showWarnings = FALSE)
  ext <- .r4vn_ext(file)
  if (ext %in% c("csv", "tsv", "txt")) {
    delimiter <- if (is.null(sep)) if (ext == "csv") "," else "\t" else sep
    utils::write.table(out, file, sep = delimiter, row.names = FALSE, col.names = header, quote = TRUE, na = na, fileEncoding = encoding, ...)
  } else if (ext == "rds") saveRDS(out, file, ...)
  else if (ext %in% c("rda", "rdata")) { data <- out; save(data, file = file, ...) }
  else if (ext == "xlsx") {
    if (requireNamespace("writexl", quietly = TRUE)) writexl::write_xlsx(stats::setNames(list(out), sheet), path = file, ...)
    else if (requireNamespace("openxlsx", quietly = TRUE)) openxlsx::write.xlsx(out, file = file, sheetName = sheet, overwrite = TRUE, ...)
    else stop("Install `writexl` or `openxlsx` to save Excel files.", call. = FALSE)
  } else if (ext == "dta") {
    .r4vn_require_optional("haven", "to save Stata files"); haven::write_dta(.r4vn_prepare_haven(out), path = file, ...)
  } else if (ext == "sav") {
    .r4vn_require_optional("haven", "to save SPSS files"); haven::write_sav(.r4vn_prepare_haven(out), path = file, ...)
  } else if (ext == "xpt") {
    .r4vn_require_optional("haven", "to save SAS transport files"); haven::write_xpt(.r4vn_prepare_haven(out), path = file, ...)
  } else if (ext == "json") {
    .r4vn_require_optional("jsonlite", "to save JSON files"); jsonlite::write_json(out, path = file, dataframe = "rows", na = "null", ...)
  } else if (ext == "parquet") {
    .r4vn_require_optional("arrow", "to save Parquet files"); arrow::write_parquet(out, sink = file, ...)
  } else stop("Unsupported output extension: .", ext, call. = FALSE)
  path <- normalizePath(file, winslash = "/", mustWork = TRUE)
  if (!isTRUE(quiet)) message("Saved ", nrow(out), " observations and ", ncol(out), " variables: ", path)
  invisible(path)
}

# ----------------------------------------------------------------------------
# Consolidated from: appenddata.R
# ----------------------------------------------------------------------------
#' Append data frames by observations
#'
#' Appends data frames or files below a master data frame. Active data is used
#' as master when available.
#'
#' @param ... Data frames or existing file paths to append.
#' @param data Optional explicit master data frame.
#' @param source `NULL`, `TRUE` for `"_source"`, or a source-variable name.
#' @param force Logical; convert incompatible columns to character.
#' @param active Logical; replace active data with the result.
#' @param quiet Logical; suppress messages.
#' @param labels Label handling when a file is opened.
#'
#' @details
#' Columns are aligned by name. Missing columns are filled with `NA`. If no
#' active data and no explicit `data` are supplied, the first object in `...`
#' becomes master.
#'
#' @return The appended data frame invisibly.
#' @export
#'
#' @examples
#' before <- data.frame(id = 1:2, age = c(20, 30))
#' after <- data.frame(id = 3:4, age = c(40, 50), sex = c("M", "F"))
#' usedf(before, quiet = TRUE)
#' appenddata(after, source = TRUE, quiet = TRUE)
#' combined <- usedf(quiet = TRUE)
#' combined2 <- appenddata(before, after, active = FALSE, quiet = TRUE)
appenddata <- function(..., data = NULL, source = NULL, force = FALSE,
                       active = TRUE, quiet = FALSE,
                       labels = c("factor", "labelled", "numeric")) {
  labels <- match.arg(labels)
  exprs <- as.list(substitute(list(...)))[-1L]
  vals <- list(...)
  if (is.null(data)) {
    if (.r4vn_has_active()) {
      master <- .r4vn_get_active(); master_name <- .r4vn_state$name
    } else {
      if (!length(vals)) stop("No data supplied and no active data exists.", call. = FALSE)
      master <- .r4vn_input_data(vals[[1L]], labels); master_name <- .r4vn_source_name(exprs[[1L]], vals[[1L]], 1L)
      vals <- vals[-1L]; exprs <- exprs[-1L]
    }
  } else {
    if (!is.data.frame(data)) stop("`data` must be a data frame.", call. = FALSE)
    master <- data; master_name <- deparse(substitute(data))
  }
  lst <- list(master); source_names <- master_name
  if (length(vals)) for (i in seq_along(vals)) {
    lst[[length(lst) + 1L]] <- .r4vn_input_data(vals[[i]], labels)
    source_names <- c(source_names, .r4vn_source_name(exprs[[i]], vals[[i]], i + 1L))
  }
  source_var <- if (isTRUE(source)) "_source" else if (is.character(source) && length(source) == 1L) source else NULL
  if (!is.null(source_var)) {
    if (source_var %in% unique(unlist(lapply(lst, names), use.names = FALSE))) stop("Source variable already exists: ", source_var, call. = FALSE)
    for (i in seq_along(lst)) lst[[i]][[source_var]] <- source_names[i]
  }
  out <- .r4vn_bind_rows(lst, force)
  if (!is.null(source_var)) {
    out[[source_var]] <- factor(out[[source_var]], levels = source_names)
    attr(out[[source_var]], "label") <- "Data source"
  }
  if (isTRUE(active)) .r4vn_set_active(out, "append result", quiet = quiet)
  else if (!isTRUE(quiet)) message("Appended result: ", nrow(out), " observations, ", ncol(out), " variables.")
  invisible(out)
}

# ----------------------------------------------------------------------------
# Consolidated from: mergedata.R
# ----------------------------------------------------------------------------
#' Merge data frames by key variables
#'
#' Merges a using data frame or file into a master data frame. Active data is
#' used as master by default. Cardinality can be checked like Stata merges.
#'
#' @param using Data frame or existing file path.
#' @param by Key variables: bare name, `vars(...)`, or character vector.
#' @param data Optional explicit master data frame.
#' @param type One of `"1:1"`, `"1:m"`, `"m:1"`, or `"m:m"`.
#' @param join One of `"full"`, `"left"`, `"right"`, or `"inner"`.
#' @param suffix Two suffixes for overlapping non-key variables.
#' @param generate Merge-status variable name, or `NULL`. Codes are 1 master
#'   only, 2 using only, and 3 matched.
#' @param keep Optional status codes to retain, such as `3` or `c(1, 3)`.
#' @param update Logical; fill missing master values from using variables with
#'   the same names.
#' @param replace Logical; with `update = TRUE`, replace nonmissing master values
#'   by nonmissing using values.
#' @param active Logical; replace active data with the result.
#' @param quiet Logical; suppress messages.
#' @param labels Label handling when `using` is a file path.
#'
#' @return The merged data frame invisibly.
#' @export
#'
#' @examples
#' master <- data.frame(id = 1:3, age = c(20, 30, 40))
#' using <- data.frame(id = 2:4, sex = c("F", "M", "F"))
#' usedf(master, quiet = TRUE)
#' mergedata(using, by = id, type = "1:1", quiet = TRUE)
#' result <- usedf(quiet = TRUE)
#' result2 <- mergedata(using, data = master, by = id, type = "1:1",
#'                      active = FALSE, quiet = TRUE)
mergedata <- function(using, by, data = NULL,
                      type = c("1:1", "1:m", "m:1", "m:m"),
                      join = c("full", "left", "right", "inner"),
                      suffix = c("_master", "_using"), generate = "_merge",
                      keep = NULL, update = FALSE, replace = FALSE,
                      active = TRUE, quiet = FALSE,
                      labels = c("factor", "labelled", "numeric")) {
  type <- match.arg(type); join <- match.arg(join); labels <- match.arg(labels)
  if (isTRUE(replace) && !isTRUE(update)) stop("`replace = TRUE` requires `update = TRUE`.", call. = FALSE)
  if (length(suffix) != 2L) stop("`suffix` must contain two values.", call. = FALSE)
  master <- if (is.null(data)) .r4vn_get_active() else data
  if (!is.data.frame(master)) stop("Master data must be a data frame.", call. = FALSE)
  using_data <- .r4vn_input_data(using, labels)
  by_names <- .r4vn_names_from_expr(substitute(by), names(master))
  missing_keys <- setdiff(by_names, names(using_data))
  if (length(missing_keys)) stop("Using data is missing key variables: ", paste(missing_keys, collapse = ", "), call. = FALSE)
  .r4vn_check_merge_type(master, using_data, by_names, type)

  master_meta <- lapply(master, function(x) list(label = attr(x, "label", exact = TRUE), values = attr(x, "r4vn_values", exact = TRUE)))
  using_meta <- lapply(using_data, function(x) list(label = attr(x, "label", exact = TRUE), values = attr(x, "r4vn_values", exact = TRUE)))
  mrow <- ".r4vn_master_row"; urow <- ".r4vn_using_row"
  while (mrow %in% c(names(master), names(using_data))) mrow <- paste0(mrow, "_")
  while (urow %in% c(names(master), names(using_data), mrow)) urow <- paste0(urow, "_")
  master[[mrow]] <- seq_len(nrow(master)); using_data[[urow]] <- seq_len(nrow(using_data))
  all_x <- join %in% c("full", "left"); all_y <- join %in% c("full", "right")
  out <- base::merge(master, using_data, by = by_names, all.x = all_x, all.y = all_y, sort = FALSE, suffixes = suffix)
  indicator <- ifelse(is.na(out[[mrow]]), 2L, ifelse(is.na(out[[urow]]), 1L, 3L))
  if (join == "inner") {
    selected <- indicator == 3L; out <- out[selected, , drop = FALSE]; indicator <- indicator[selected]
  }

  overlap <- setdiff(intersect(names(master), names(using_data)), c(by_names, mrow, urow))
  if (isTRUE(update) && length(overlap)) for (v in overlap) {
    vm <- paste0(v, suffix[1L]); vu <- paste0(v, suffix[2L])
    if (!vm %in% names(out) || !vu %in% names(out)) next
    out[[v]] <- .r4vn_coalesce(out[[vm]], out[[vu]], replace)
    out[[vm]] <- NULL; out[[vu]] <- NULL
    meta <- master_meta[[v]]
    if (is.null(meta$label) && v %in% names(using_meta)) meta <- using_meta[[v]]
    if (!is.null(meta$label)) attr(out[[v]], "label") <- meta$label
    if (!is.null(meta$values)) attr(out[[v]], "r4vn_values") <- meta$values
  }

  out[[mrow]] <- NULL; out[[urow]] <- NULL
  if (!is.null(keep)) {
    keep <- as.integer(keep)
    if (any(!keep %in% 1:3)) stop("`keep` may contain only 1, 2, and 3.", call. = FALSE)
    selected <- indicator %in% keep; out <- out[selected, , drop = FALSE]; indicator <- indicator[selected]
  }
  if (!is.null(generate)) {
    if (!is.character(generate) || length(generate) != 1L || !nzchar(generate)) stop("`generate` must be one name or NULL.", call. = FALSE)
    if (generate %in% names(out)) stop("Merge-status variable already exists: ", generate, call. = FALSE)
    out[[generate]] <- indicator
    attr(out[[generate]], "label") <- "Merge result"
    attr(out[[generate]], "r4vn_values") <- c("1" = "Master only", "2" = "Using only", "3" = "Matched")
  }
  rownames(out) <- NULL
  counts <- tabulate(indicator, nbins = 3L)
  if (isTRUE(active)) .r4vn_set_active(out, "merge result", quiet = quiet)
  else if (!isTRUE(quiet)) message("Merge result: ", nrow(out), " observations. Master only=", counts[1L], "; Using only=", counts[2L], "; Matched=", counts[3L], ".")
  invisible(out)
}