VALIDATOR fails if only formula contrast is specified (#80)

* Work when only using formula and no comparison

* Rename formula_vars in accessory.R

* Validate contrasts individually and remove use of temporary columns

* Add test for fomula contrasts alone

Author: delfiterradas

R/accessory.R

@@ -1019,41 +1019,48 @@ read_contrasts <-
     success <- checkListIsSubset(blocking, colnames(samples), "blocking variables", "sample metadata")
   }
 
-  # Extract design matrix columns from contrasts: the variable column plus any blocking factors.
-  design_cols <- unique(na.omit(c(contrasts[[variable_column]], blocking)))
-  design_matrix <- samples[, design_cols, drop = FALSE]
-  
-  # Ensure there are no NA values in the design matrix.
-  if (any(is.na(design_matrix))) {
-    stop("NA values found in one or more design matrix columns.")
-  }
-  
-  # Check that the design matrix is full rank.
-  mm <- model.matrix(~ . - 1, data = design_matrix)
-  if (qr(mm)$rank < ncol(mm)) {
-    stop(paste("Design matrix is not full rank.", "Model matrix columns:", paste(colnames(mm), collapse = ", "), "\n"))
-  }
-  
-  # Warn about continuous covariates in the design matrix columns.
-  for (col in design_cols) {
-    if (is.numeric(samples[[col]])) {
-      warning(paste("Column", col, "is numeric and may be treated as continuous."))
+  # Ensure reference and target are valid for their variable
+  for (i in 1:nrow(contrasts)) {
+    blocking_vars <- simpleSplit(contrasts[[blocking_column]][i], ";")
+
+    # Extract design matrix columns from contrasts: the variable column plus any blocking factors.
+    # For formula-based contrasts, extract variables from the formula itself.
+    formula_vars <- character(0)
+    if ("formula" %in% colnames(contrasts) && !is.na(contrasts$formula[i])) {
+      formula_vars <- all.vars(as.formula(contrasts$formula[i]))
     }
-  }
-  
-  # Check that values in design matrix columns do not contain disallowed special characters.
-  for (col in design_cols) {
-    vals <- as.character(samples[[col]])
-    for (sc in c("/", "\\\\")) { # Default special characters: c("/", "\\\\")
-      if (any(grepl(sc, vals))) {
-        warning(paste("Column", col, "contains special character", sc, 
-                      "which may cause issues downstream."))
+
+    design_cols <- unique(na.omit(c(contrasts[[variable_column]][i], blocking_vars, formula_vars)))
+    design_matrix <- samples[, design_cols, drop = FALSE]
+    
+    # Ensure there are no NA values in the design matrix.
+    if (any(is.na(design_matrix))) {
+      stop("NA values found in one or more design matrix columns.")
+    }
+    
+    # Check that the design matrix is full rank.
+    mm <- model.matrix(~ . - 1, data = design_matrix)
+    if (qr(mm)$rank < ncol(mm)) {
+      stop(paste("Design matrix is not full rank.", "Model matrix columns:", paste(colnames(mm), collapse = ", "), "\n"))
+    }
+    
+    # Warn about continuous covariates in the design matrix columns.
+    for (col in design_cols) {
+      if (is.numeric(samples[[col]])) {
+        warning(paste("Column", col, "is numeric and may be treated as continuous."))
+      }
+    }
+    
+    # Check that values in design matrix columns do not contain disallowed special characters.
+    for (col in design_cols) {
+      vals <- as.character(samples[[col]])
+      for (sc in c("/", "\\\\")) { # Default special characters: c("/", "\\\\")
+        if (any(grepl(sc, vals))) {
+          warning(paste("Column", col, "contains special character", sc, 
+                        "which may cause issues downstream."))
+        }
       }
     }
-  }
-
-  # Ensure reference and target are valid for their variable
-  for (i in 1:nrow(contrasts)) {
     var <- contrasts[i, variable_column]
     ref <- contrasts[i, reference_column]
     tgt <- contrasts[i, target_column]

tests/testthat/test-accessory.R

@@ -81,5 +81,48 @@ contrasts:
   expect_equal(contrasts$make_contrasts_str[4], "genotypeWT.treatmentTreated")
   expect_equal(contrasts$make_contrasts_str[5], "genotypeWT.treatmentTreated.time")
 
+  unlink(yaml_file)
+})
+
+# read_contrasts() using only formula based contrasts
+
+test_that("read_contrasts parses YAML correctly using only formula based contrasts", {
+  samples <- data.frame(
+    sample = c("Sample1", "Sample7", "Sample13", "Sample19", "Sample16"),
+    genotype = c("WT", "WT", "KO", "KO", "KO"),
+    treatment = c("Control", "Treated", "Control", "Treated", "Control"),
+    time = c(1, 1, 1, 1, 16),
+    batch = c("b1", "b1", "b1", "b1", "b3"),
+    stringsAsFactors = FALSE
+  )
+
+  yaml_content <- "
+contrasts:
+  - id: treatment_plus_genotype
+    formula: \"~ treatment + genotype\"
+    make_contrasts_str: \"treatmentTreated\"
+  - id: interaction_genotype_treatment
+    formula: \"~ genotype * treatment\"
+    make_contrasts_str: \"genotypeWT.treatmentTreated\"
+  - id: full_model_with_interactions
+    formula: \"~ genotype * treatment * time\"
+    make_contrasts_str: \"genotypeWT.treatmentTreated.time\"
+"
+
+  yaml_file <- tempfile(fileext = ".yaml")
+  writeLines(yaml_content, yaml_file)
+
+  contrasts <- read_contrasts(yaml_file, samples)
+
+  # Test basic structure
+  expect_true(is.data.frame(contrasts))
+  expect_equal(nrow(contrasts), 3)
+  expect_true(all(c("id", "variable", "reference", "target", "blocking", "formula", "make_contrasts_str") %in% colnames(contrasts)))
+
+  # Test specific rows
+  expect_equal(contrasts$formula[1], "~ treatment + genotype")
+  expect_equal(contrasts$make_contrasts_str[2], "genotypeWT.treatmentTreated")
+  expect_equal(contrasts$make_contrasts_str[3], "genotypeWT.treatmentTreated.time")
+
   unlink(yaml_file)
 })