R/spec_construct.R

In artoo: Lossless CDISC-Native Input and Output for Clinical Datasets

# spec_construct.R — the friendly artoo_spec() constructor.

# Coerce one slot to its schema: drop to a plain data frame, error on a
# missing required column, coerce known columns to their storage mode, fill
# missing optional columns with a typed NA, and leave unknown columns as-is.
#' @noRd
.coerce_slot <- function(df, schema, req, slot, call) {
  if (is.null(df)) {
    cols <- lapply(schema, function(m) .na_mode(m, 0L))
    return(as.data.frame(cols, stringsAsFactors = FALSE, check.names = FALSE))
  }
  df <- as.data.frame(df, stringsAsFactors = FALSE, check.names = FALSE)
  missing <- setdiff(req, names(df))
  if (length(missing)) {
    .artoo_abort(
      c(
        "{.arg {slot}} is missing a required column{cli::qty(missing)}{?s}: {.val {missing}}.",
        "i" = "Required: {.val {req}}."
      ),
      kind = "spec",
      call = call
    )
  }
  n <- nrow(df)
  for (nm in intersect(names(schema), names(df))) {
    df[[nm]] <- .coerce_mode(df[[nm]], schema[[nm]])
  }
  for (nm in setdiff(names(schema), names(df))) {
    df[[nm]] <- .na_mode(schema[[nm]], n)
  }
  df
}

#' Construct a CDISC specification
#'
#' Build and validate a `artoo_spec` from dataset, variable, and codelist
#' tables. Each table is coerced to a plain data frame, missing optional
#' columns are filled with typed `NA`s, every variable type is canonicalised
#' to the CDISC `dataType` vocabulary, and cross-slot integrity (dataset and
#' codelist references) is checked before the object is returned. The spec
#' is the lingua franca the rest of artoo reads, applies, and serialises.
#'
#' @details
#' **Coerce, then validate.** Each table is first coerced to a plain data
#' frame (a `tibble` is accepted and demoted); known columns are cast to
#' their storage mode and absent optional columns are added as typed `NA`,
#' so every downstream reader can trust the schema. Validation runs only
#' after coercion, on the completed slots.
#'
#' **Type canonicalisation.** `variables$data_type` is mapped through the
#' closed CDISC `dataType` vocabulary (`string`, `integer`, `decimal`,
#' `float`, `double`, `boolean`, `date`, `datetime`, `time`, `URI`). Common
#' SAS / P21 spellings resolve automatically (`"text"`, `"Char"`,
#' `"integer (8)"`, ...); an unrecognised token aborts with
#' `artoo_error_type`.
#'
#' **Cross-slot integrity.** Construction fails (`artoo_error_spec`) if a
#' variable names a dataset absent from `datasets`, or references a
#' `codelist_id` absent from `codelists`.
#'
#' **One spec, one standard.** A `artoo_spec` carries exactly one CDISC
#' standard, stored as the scalar `@standard` property. The constructor
#' resolves it from the `standard` argument, a `standard` column in
#' `datasets` (the P21 workbook shape), and a `standard` field in `study`
#' (the Define-XML shape) — those columns are consumed, so `@standard` is
#' the single home. More than one distinct value aborts with
#' `artoo_error_spec`; scope the source to one standard (e.g.
#' `read_spec(path, datasets = ...)`) instead of mixing.
#'
#' **One study vocabulary.** Well-known study fields are canonicalised to
#' the CDISC ODM GlobalVariables names, snake_cased: `study_name`,
#' `study_description`, `protocol_name`. Source spellings resolve
#' automatically (`StudyName`, `studyid`, ...); fields the vocabulary does
#' not know pass through verbatim. Aliases that disagree on a value abort
#' with `artoo_error_spec`.
#'
#' @param datasets *Dataset-level metadata table.*
#'   `<data.frame>: required`. One row per dataset; must carry a `dataset`
#'   column. Optional columns `label`, `class`, `structure`, `keys` are
#'   filled with `NA` when absent.
#' @param variables *Variable-level metadata table.*
#'   `<data.frame>: required`. One row per variable; must carry `dataset`,
#'   `variable`, and `data_type`. The `data_type` column is canonicalised to
#'   a CDISC `dataType` (e.g. `"text"` becomes `"string"`).
#'
#'   **Requirement:** every `dataset` value must appear in `datasets`.
#' @param codelists *Controlled-terminology terms.*
#'   `<data.frame> | NULL`. Must carry `codelist_id` and `term` when
#'   supplied.
#'
#'   **Interaction:** every `codelist_id` referenced by `variables` must
#'   resolve here.
#' @param study *Study-level metadata.* `<data.frame> | NULL`. A single row
#'   of named study fields. Well-known fields are canonicalised to
#'   `study_name`, `study_description`, and `protocol_name` (aliases such
#'   as `StudyName` or `studyid` resolve automatically); other fields pass
#'   through verbatim. A `standard` field, when present, is consumed into
#'   `@standard`.
#' @param standard *The CDISC standard the spec implements.*
#'   `<character(1)> | NULL`. E.g. `"ADaMIG 1.1"` or `"SDTMIG 3.2"`. When
#'   `NULL` (default) it is resolved from `datasets$standard` or
#'   `study$standard`; absent everywhere, `@standard` is `NA`.
#'
#'   **Restriction:** all sources must agree on one value; conflicting
#'   standards abort with `artoo_error_spec`.
#' @param values *Value-level (VLM) metadata.* `<data.frame> | NULL`.
#' @param methods *Derivation methods.* `<data.frame> | NULL`. The
#'   Define-XML method definitions variables reference by `method_id`; must
#'   carry `method_id` when supplied. Completeness (e.g. a referenced
#'   method has a description) is checked by [validate_spec()], not here.
#' @param comments *Comment definitions.* `<data.frame> | NULL`. Referenced
#'   by `comment_id`; must carry `comment_id` when supplied.
#' @param documents *Document references.* `<data.frame> | NULL`. Referenced
#'   by `document_id`; must carry `document_id` when supplied.
#'
#' @return *A validated `artoo_spec` object.* Inspect it with
#'   [spec_datasets()] / [spec_variables()], or check it with
#'   [validate_spec()].
#'
#' @examples
#' # ---- Example 1: build a spec from the bundled CDISC-pilot tables ----
#' #
#' # `cdisc_sdtm_datasets` and `cdisc_sdtm_variables` hold the CDISC pilot SDTM
#' # metadata in the shape artoo_spec() expects; the constructor
#' # canonicalises every type and checks cross-slot integrity.
#' spec <- artoo_spec(cdisc_sdtm_datasets, cdisc_sdtm_variables, codelists = cdisc_codelists)
#' spec_datasets(spec)
#'
#' # ---- Example 2: a focused spec for a single dataset ----
#' #
#' # Slice the bundled tables to one dataset (DM) to build a smaller spec.
#' dm_ds <- cdisc_sdtm_datasets[cdisc_sdtm_datasets$dataset == "DM", ]
#' dm_var <- cdisc_sdtm_variables[cdisc_sdtm_variables$dataset == "DM", ]
#' dm_spec <- artoo_spec(dm_ds, dm_var, codelists = cdisc_codelists)
#' head(spec_variables(dm_spec, "DM")[, c("variable", "label", "data_type")])
#'
#' @seealso
#' **Inspect:** [spec_datasets()], [spec_variables()], [spec_codelists()],
#' [spec_keys()], [spec_study()].
#'
#' **Check:** [validate_spec()]. **Predicate:** [is_artoo_spec()].
#' @export
artoo_spec <- function(
  datasets = NULL,
  variables = NULL,
  codelists = NULL,
  study = NULL,
  values = NULL,
  methods = NULL,
  comments = NULL,
  documents = NULL,
  standard = NULL
) {
  call <- rlang::caller_env()
  if (is.null(datasets) || is.null(variables)) {
    .artoo_abort(
      c(
        "Both {.arg datasets} and {.arg variables} are required.",
        "i" = "Pass at least a {.code dataset} table and a variable table."
      ),
      kind = "input",
      call = call
    )
  }
  datasets <- .coerce_slot(
    datasets,
    .spec_cols_datasets,
    .spec_req_datasets,
    "datasets",
    call
  )
  variables <- .coerce_slot(
    variables,
    .spec_cols_variables,
    .spec_req_variables,
    "variables",
    call
  )
  codelists <- .coerce_slot(
    codelists,
    .spec_cols_codelists,
    .spec_req_codelists,
    "codelists",
    call
  )
  methods <- .coerce_slot(
    methods,
    .spec_cols_methods,
    .spec_req_methods,
    "methods",
    call
  )
  comments <- .coerce_slot(
    comments,
    .spec_cols_comments,
    .spec_req_comments,
    "comments",
    call
  )
  documents <- .coerce_slot(
    documents,
    .spec_cols_documents,
    .spec_req_documents,
    "documents",
    call
  )
  study <- if (is.null(study)) {
    data.frame()
  } else {
    as.data.frame(study, stringsAsFactors = FALSE, check.names = FALSE)
  }
  study <- .canonicalize_study(study, call)

  # Demote a tibble (or other data-frame subclass) value-level table to a
  # plain data frame, so every slot is a uniform data.frame and a spec
  # round-trips identically through write_spec()/read_spec().
  if (!is.null(values)) {
    values <- as.data.frame(
      values,
      stringsAsFactors = FALSE,
      check.names = FALSE
    )
    # An all-NA column has no type signal on a JSON round-trip: jsonlite writes
    # [null, ...] and reads it back as logical, so write_spec()/read_spec()
    # would flip a character value-level column (e.g. an all-NA method_id) to
    # logical. Canonicalize every all-NA column to character; this constructor
    # runs on both build and read, so the round-trip becomes a fixed point.
    allna <- vapply(values, function(col) all(is.na(col)), logical(1))
    if (any(allna)) {
      values[allna] <- lapply(values[allna], as.character)
    }
  }

  # Derive per-variable key_sequence from the dataset-level keys string when
  # the source does not provide one (the P21 shape: keys live only on the
  # Datasets sheet). One canonical model: the meta keySequence — and so the
  # Dataset-JSON output — then carries the keys regardless of source.
  variables <- .derive_key_sequence(datasets, variables)

  # Resolve the one CDISC standard from every place a source can carry it
  # (explicit argument, P21 datasets column, Define-XML study field), then
  # strip those columns — @standard is the single home.
  standard <- .resolve_standard(standard, datasets, study, call)
  datasets$standard <- NULL
  study$standard <- NULL

  # Canonicalise each variable's data_type to a CDISC dataType.
  if (nrow(variables)) {
    variables$data_type <- vapply(
      seq_len(nrow(variables)),
      function(i) {
        .parse_type(
          variables$data_type[[i]],
          variable = variables$variable[[i]],
          call = call
        )
      },
      character(1)
    )
  }

  .spec_check_refs(datasets, variables, codelists, call)

  artoo_spec_class(
    standard = standard,
    study = study,
    datasets = datasets,
    variables = variables,
    codelists = codelists,
    methods = methods,
    comments = comments,
    documents = documents,
    values = values
  )
}

# Fill variables$key_sequence from datasets$keys for datasets where the
# source provided none. Explicit key_sequence values always win (validation
# checks their consistency with the keys string separately).
#' @noRd
.derive_key_sequence <- function(datasets, variables) {
  if (!nrow(variables) || !nrow(datasets) || !"keys" %in% names(datasets)) {
    return(variables)
  }
  for (i in seq_len(nrow(datasets))) {
    ds <- datasets$dataset[i]
    raw <- datasets$keys[i]
    if (is.na(ds) || is.na(raw) || !nzchar(trimws(raw))) {
      next
    }
    rows <- !is.na(variables$dataset) & variables$dataset == ds
    if (!any(rows) || !all(is.na(variables$key_sequence[rows]))) {
      next
    }
    keys <- .split_keys(trimws(raw))
    idx <- match(variables$variable, keys)
    set <- rows & !is.na(idx)
    variables$key_sequence[set] <- as.integer(idx[set])
  }
  variables
}

# The canonical study vocabulary: CDISC ODM GlobalVariables, snake_cased.
# Keys are the canonical field names; values are the normalised (lowercase,
# punctuation-stripped) alias spellings each source uses — the P21 Define
# sheet's verbatim attributes (StudyName), the Define-XML reader
# (study_name), and the legacy hand-built shape (studyid).
#' @noRd
.study_field_aliases <- list(
  study_name = c("studyname", "studyid"),
  study_description = c("studydescription"),
  protocol_name = c("protocolname")
)

# Canonicalise the study frame's well-known fields so every consumer
# (print, meta studyOID, validate_spec) reads ONE vocabulary. Unknown
# fields pass through verbatim (losslessness); aliases that disagree on a
# non-blank value abort, mirroring .resolve_standard.
#' @noRd
.canonicalize_study <- function(study, call) {
  if (!length(names(study)) || !nrow(study)) {
    return(study)
  }
  norm <- gsub("[^a-z0-9]", "", tolower(names(study)))
  for (canon in names(.study_field_aliases)) {
    hit <- which(norm %in% c(canon, .study_field_aliases[[canon]]))
    if (!length(hit)) {
      next
    }
    vals <- unlist(lapply(hit, function(i) as.character(study[[i]])))
    vals <- trimws(vals)
    vals <- unique(vals[!is.na(vals) & nzchar(vals)])
    if (length(vals) > 1L) {
      fields <- names(study)[hit]
      .artoo_abort(
        c(
          "Study fields that name the {.field {canon}} disagree.",
          "x" = "{.val {fields}} carry {length(vals)} distinct values: {.val {vals}}.",
          "i" = "Reconcile them to one value, or drop the stale field."
        ),
        kind = "spec",
        call = call
      )
    }
    keep <- setdiff(seq_along(study), hit)
    study <- study[, keep, drop = FALSE]
    study[[canon]] <- if (length(vals)) vals else NA_character_
    norm <- gsub("[^a-z0-9]", "", tolower(names(study)))
  }
  study
}

# Resolve the spec's one CDISC standard. Unions the explicit argument, a
# P21-style `standard` column on the datasets table, and a Define-XML-style
# `standard` field on the study row; drops NA/blank; aborts when more than
# one distinct value survives. Returns a length-1 character (NA when no
# source names a standard).
#' @noRd
.resolve_standard <- function(standard, datasets, study, call) {
  cands <- c(
    standard,
    if ("standard" %in% names(datasets)) datasets$standard,
    if ("standard" %in% names(study)) study$standard
  )
  cands <- trimws(as.character(cands))
  cands <- unique(cands[!is.na(cands) & nzchar(cands)])
  if (length(cands) > 1L) {
    .artoo_abort(
      c(
        "A {.cls artoo_spec} carries exactly one CDISC standard.",
        "x" = "Found {length(cands)} distinct standards: {.val {cands}}.",
        "i" = "Split the source by standard, or scope the read to one standard's datasets with {.code read_spec(path, datasets = ...)}."
      ),
      kind = "spec",
      call = call
    )
  }
  if (length(cands)) cands else NA_character_
}

# Friendly cross-slot reference checks (the S7 validator repeats these as a
# last line of defence). Each message carries a single varying quantity so
# cli pluralisation is unambiguous.
#' @noRd
.spec_check_refs <- function(datasets, variables, codelists, call) {
  if (nrow(variables)) {
    # Duplicate (dataset, variable) definitions make every downstream step
    # ambiguous (which label? which type?). Fail at construction, with the
    # exact rows, instead of deep inside apply_spec() after the user has
    # already derived everything. read_spec(on_duplicate=) offers the
    # keep-first policy for workbooks that ship with duplicates.
    key <- paste(variables$dataset, variables$variable, sep = ".")
    keyed <- !is.na(variables$dataset) & !is.na(variables$variable)
    dup_keys <- unique(key[keyed][duplicated(key[keyed])])
    if (length(dup_keys)) {
      lines <- vapply(
        utils::head(dup_keys, 3L),
        function(k) {
          rows <- which(keyed & key == k)
          sprintf(
            "Rows %s of {.arg variables} all define %s.",
            paste(rows, collapse = " and "),
            k
          )
        },
        character(1)
      )
      .artoo_abort(
        c(
          "{.arg variables} defines {length(dup_keys)} variable{?s} more than once.",
          stats::setNames(lines, rep("x", length(lines))),
          "i" = "Remove the duplicate rows, or read the file with {.code read_spec(path, on_duplicate = \"first\")}."
        ),
        kind = "spec",
        call = call
      )
    }
    orphan <- setdiff(unique(variables$dataset), datasets$dataset)
    orphan <- orphan[!is.na(orphan)]
    if (length(orphan)) {
      .artoo_abort(
        c(
          "Some variables reference a dataset not in {.arg datasets}.",
          "x" = "Unknown dataset{?s}: {.val {orphan}}.",
          "i" = "Add the dataset to {.arg datasets}, or fix {.arg variables}."
        ),
        kind = "spec",
        call = call
      )
    }
    used <- unique(variables$codelist_id[
      !is.na(variables$codelist_id) & nzchar(variables$codelist_id)
    ])
    known <- if ("codelist_id" %in% names(codelists)) {
      unique(codelists$codelist_id)
    } else {
      character(0)
    }
    unresolved <- setdiff(used, known)
    if (length(unresolved)) {
      .artoo_abort(
        c(
          "Some variables reference a codelist not in {.arg codelists}.",
          "x" = "Unresolved codelist_id{?s}: {.val {unresolved}}.",
          "i" = "Add the codelist's terms to {.arg codelists}."
        ),
        kind = "spec",
        call = call
      )
    }
  }
}

#' Test for a artoo_spec object
#'
#' Report whether an object is a `artoo_spec` — the validated CDISC
#' specification that drives the artoo workflow (spec -> apply_spec ->
#' read_/write_). [artoo_spec()] builds one; this is the type guard before you
#' pass it to [apply_spec()] or reach into it with the spec accessors.
#'
#' @param x *Object to test.* `<any>`.
#'
#' @return *A `<logical(1)>`*: `TRUE` when `x` is a `artoo_spec`, else `FALSE`.
#'
#' @examples
#' # ---- Example 1: guard a built specification ----
#' #
#' # artoo_spec() assembles and validates a spec; is_artoo_spec() confirms the
#' # type before you drive apply_spec() with it.
#' spec <- artoo_spec(cdisc_sdtm_datasets, cdisc_sdtm_variables, codelists = cdisc_codelists)
#' is_artoo_spec(spec)
#'
#' # ---- Example 2: an ordinary object is not a spec ----
#' #
#' # Any non-artoo_spec value — a bare data frame, say — returns FALSE.
#' is_artoo_spec(cdisc_dm)
#'
#' @seealso [artoo_spec()] to build one; [is_artoo_meta()] for the metadata
#'   guard.
#' @export
is_artoo_spec <- function(x) {
  S7::S7_inherits(x, artoo_spec_class)
}