Add parse_variables_sheet function with validation

NAMESPACE

@@ -3,6 +3,7 @@
 export(get_table_name)
 export(is_equal)
 export(is_table_feeder_var)
+export(parse_variables_sheet)
 export(rec_with_table)
 export(set_data_labels)
 importFrom(dplyr,do)

R/parse-variables-sheet.R

@@ -0,0 +1,196 @@
+#' Parse and validate a variables sheet
+#'
+#' @param variables_sheet A data frame containing the variables sheet
+#'
+#' @return If validation succeeds, returns the parsed variables sheet.
+#' If validation fails, returns a named list with the following fields:
+#' * **success**: set to FALSE
+#' * **errors**: the list of errors where each item is a named list. The fields
+#'   in the list depend on the type of error but the following two fields will
+#'   always be there:
+#'   * **type**: The error ID
+#'   * **message**: The human readable error message
+#' @export
+parse_variables_sheet <- function(variables_sheet) {
+  input_errors <- .validate_variables_sheet_arg(variables_sheet)
+  if (length(input_errors) > 0) {
+    return(list(
+      success = FALSE,
+      errors = input_errors
+    ))
+  }
+
+  validation_errors <- .validate_derived_variables(variables_sheet)
+  if (length(validation_errors) > 0) {
+    return(list(
+      success = FALSE,
+      errors = validation_errors
+    ))
+  }
+
+  class(variables_sheet) <- c("variables_sheet", class(variables_sheet))
+  return(variables_sheet)
+}
+
+#' Run basic checks for the variables sheet used in the parse_variables_sheet
+#' function
+#'
+#' @param variables_sheet
+#'
+#' @return A list of errors (empty if no errors found)
+#' @keywords internal
+.validate_variables_sheet_arg <- function(variables_sheet) {
+  if (!checkmate::test_data_frame(variables_sheet)) {
+    return(list(.create_invalid_input_type_error(variables_sheet)))
+  }
+
+  required_cols <- c(
+    pkg.env$columns.variable,
+    pkg.env$columns.variableStart
+  )
+  variables_sheet_cols <- colnames(variables_sheet)
+  required_cols_validation <- checkmate::test_names(
+    variables_sheet_cols, must.include = required_cols)
+  if (!required_cols_validation) {
+    missing_cols <- required_cols[!required_cols %in% variables_sheet_cols]
+    actual_cols <- variables_sheet_cols
+    return(list(
+      .create_missing_required_columns_error(missing_cols, actual_cols)))
+  }
+
+  return(list())
+}
+
+#' Create an invalid input type error object
+#'
+#' @param variables_sheet The invalid input that was passed
+#'
+#' @return A list containing the error object with type, actual_type, and
+#' message fields
+#' @keywords internal
+.create_invalid_input_type_error <- function(variables_sheet) {
+  actual_type <- typeof(variables_sheet)
+  return(list(
+    type = "invalid_input_type",
+    actual_type = actual_type,
+    message = paste0(
+      "variables_sheet must be a data.frame, not a ",
+      actual_type
+    )
+  ))
+}
+
+#' Create a missing required columns error object
+#'
+#' @param missing_cols A character vector of column names that are missing
+#' @param actual_cols A character vector of column names that are present
+#'
+#' @return A list containing the error object with type, missing_cols,
+#' actual_cols, and message fields
+#' @keywords internal
+.create_missing_required_columns_error <- function(missing_cols, actual_cols) {
+  return(list(
+    type = "missing_required_columns",
+    missing_cols = missing_cols,
+    actual_cols = actual_cols,
+    message = paste0(
+      "variables_sheet is missing required columns: ",
+      paste(missing_cols, collapse = ", "),
+      ". Columns found: ",
+      paste(actual_cols, collapse = ", ")
+    )
+  ))
+}
+
+#' Create an invalid dependency error object
+#'
+#' @param row The row number in the variables sheet where the error occurred
+#' @param db_column_var The database column variable that was incorrectly used
+#'
+#' @return A list containing the error object with type, row, message, and
+#' db_column_var fields
+#' @keywords internal
+.create_invalid_dependency_error <- function(row, db_column_var) {
+  return(list(
+    type = "invalid_dependency",
+    row = row,
+    db_column_var = db_column_var,
+    message = glue::glue(
+      "Derived variable at row {row} uses database column ",
+      "'{db_column_var}' directly. Derived variables must only use ",
+      "non-derived or other derived variables."
+    )
+  ))
+}
+
+#' Validate the derived variables in a variables sheet
+#'
+#' @param variables_sheet A data frame containing the variables sheet
+#'
+#' @return A list of errors (empty if no errors found)
+#' @keywords internal
+.validate_derived_variables <- function(variables_sheet) {
+  if (nrow(variables_sheet) == 0) {
+    return(list())
+  }
+
+  errors <- seq_len(nrow(variables_sheet)) |>
+    purrr::map(function(i) {
+      row <- variables_sheet[i, ]
+
+      if (!is_derived_var(row)) {
+        return(NULL)
+      }
+
+      variable_start <- row[[pkg.env$columns.variableStart]]
+      start_vars <- .extract_start_variables(variable_start)
+      current_errors <- start_vars |>
+        purrr::keep(.is_database_column_reference) |>
+        purrr::map(function(start_var) {
+          return(.create_invalid_dependency_error(i, start_var))
+        })
+      return(current_errors)
+    }) |>
+    purrr::compact() |>
+    purrr::flatten()
+  return(errors)
+}
+
+#' Extract start variables from a variableStart column value
+#'
+#' @param variable_start The variableStart string
+#'
+#' @return A character vector of start variable names
+#' @keywords internal
+.extract_start_variables <- function(variable_start) {
+  derived_var_pattern <- "DerivedVar::\\[(.+?)\\]|DerivedVar::\\[\\]"
+  matches <- regmatches(
+    variable_start, regexec(derived_var_pattern, variable_start))
+
+  if (length(matches[[1]]) < 2) {
+    return(character(0))
+  }
+
+  content <- matches[[1]][2]
+
+  if (is.na(content) || nchar(trimws(content)) == 0) {
+    return(character(0))
+  }
+
+  start_vars <- purrr::map(
+    strsplit(content, ",")[[1]],
+    trimws
+  )
+  return(start_vars)
+}
+
+#' Check if a start variable is a database column
+#'
+#' @param start_var The start variable string to check
+#'
+#' @return TRUE if it matches the database::column pattern, FALSE otherwise
+#' @keywords internal
+.is_database_column_reference <- function(start_var) {
+  database_column_pattern <- "\\w+::\\w+"
+  return(grepl(database_column_pattern, start_var))
+}

tests/testthat/test-parse-variables-sheet.R

@@ -0,0 +1,178 @@
+test_that("Should return the parsed variables sheet when there are non-derived
+          variables using database variables", {
+  vars_sheet <- data.frame(
+    variable = c("age", "sex", "height"),
+    variableStart = c(
+      "[age]", "cchs2001_p::sex", "[height], cchs2001_p::height"
+    )
+  )
+
+  expected_result <- data.frame(vars_sheet)
+  class(expected_result) <- c("variables_sheet", "data.frame")
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return the parsed variables sheet when there are derived
+          variables using non-derived variables", {
+  vars_sheet <- data.frame(
+    variable = c("height", "weight", "BMI"),
+    variableStart = c("[height]", "[weight]", "DerivedVar::[height, weight]")
+  )
+
+  expected_result <- data.frame(vars_sheet)
+  class(expected_result) <- c("variables_sheet", "data.frame")
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return the parsed variables sheet when there are derived
+          variables using other derived variables", {
+  vars_sheet <- data.frame(
+    variable = c("age", "height", "weight", "BMI", "BMI_x_age"),
+    variableStart = c(
+      "[age]", "height", "weight", "DerivedVar::[height, weight]",
+      "DerivedVar::[BMI, age]"
+    )
+  )
+
+  expected_result <- data.frame(vars_sheet)
+  class(expected_result) <- c("variables_sheet", "data.frame")
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return errors when there are derived variables using
+          database columns", {
+  # Tests for:
+  # 1. Derived variable using a non-derived and a database column
+  # 2. Derived variable using a database column
+  # 3. Derived variable using non-derived variables
+  # 4. Derived variable using no start variables
+  vars_sheet <- data.frame(
+    variable = c(
+      "height", "BMI", "DrinkerType", "freq_cig", "SmokerType",
+      "Empty"
+    ),
+    variableStart = c(
+      "[height]", "DerivedVar::[height, cchs2001_p::weight]",
+      "DerivedVar::[cchs2001_p::freq_drinks]", "[freq_cig]",
+      "DerivedVar::[freq_cig]",
+      "DerivedVar::[]"
+    )
+  )
+
+  expected_result <- list(
+    success = FALSE,
+    errors = list(
+      .create_invalid_dependency_error(2, "cchs2001_p::weight"),
+      .create_invalid_dependency_error(3, "cchs2001_p::freq_drinks")
+    )
+  )
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return errors when the variableStart column is missing from
+          the variables sheet", {
+  vars_sheet <- data.frame(
+    variable = c("age", "sex")
+  )
+
+  expected_result <- list(
+    success = FALSE,
+    errors = list(
+      .create_missing_required_columns_error(c("variableStart"), c("variable"))
+    )
+  )
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return errors when the variable column is missing from the
+          variables sheet", {
+  vars_sheet <- data.frame(
+    variableStart = c("[age]", "[sex]")
+  )
+
+  expected_result <- list(
+    success = FALSE,
+    errors = list(
+      .create_missing_required_columns_error(c("variable"), c("variableStart"))
+    )
+  )
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should not fail when the variable sheet has no rows", {
+  vars_sheet <- data.frame(
+    variable = character(0),
+    variableStart = character(0)
+  )
+
+  expected_result <- data.frame(vars_sheet)
+  class(expected_result) <- c("variables_sheet", "data.frame")
+
+  actual_result <- parse_variables_sheet(vars_sheet)
+
+  expect_equal(actual_result, expected_result)
+})
+
+test_that("Should return an error when the variables sheet is not a data frame",
+          {
+  null_input <- NULL
+  expected_result1 <- list(
+    success = FALSE,
+    errors = list(.create_invalid_input_type_error(null_input))
+  )
+  actual_result1 <- parse_variables_sheet(null_input)
+  expect_equal(actual_result1, expected_result1)
+
+  list_input <- list(a = 1)
+  expected_result2 <- list(
+    success = FALSE,
+    errors = list(.create_invalid_input_type_error(list_input))
+  )
+  actual_result2 <- parse_variables_sheet(list_input)
+  expect_equal(actual_result2, expected_result2)
+
+  vector_input <- c("a", "b")
+  expected_result3 <- list(
+    success = FALSE,
+    errors = list(.create_invalid_input_type_error(vector_input))
+  )
+  actual_result3 <- parse_variables_sheet(vector_input)
+  expect_equal(actual_result3, expected_result3)
+
+  numeric_input <- 42
+  expected_result4 <- list(
+    success = FALSE,
+    errors = list(.create_invalid_input_type_error(numeric_input))
+  )
+  actual_result4 <- parse_variables_sheet(numeric_input)
+  expect_equal(actual_result4, expected_result4)
+})
+
+test_that("Integration test with PBC variables sheet", {
+  pbc_vars <- read.csv("../../inst/extdata/pbc_variables.csv")
+
+  actual_result <- parse_variables_sheet(pbc_vars)
+
+  expected_result <- data.frame(pbc_vars)
+  class(expected_result) <- c("variables_sheet", "data.frame")
+
+  expect_equal(actual_result, expected_result)
+})
+