Merge pull request #19 from Boehringer-Ingelheim/update_CM_TC_snippets

Update shared CM and TC snippets and relax default arm checks.

Author: iglauss

R/CM.R

@@ -1,5 +1,7 @@
-# YT#VHb3a67af97b323ee47762788154a489fd#VHa53bd254d6ac8e6a19dfa057febb06b5#
+# YT#VH20fe8acb2e57832933eb60226847381a#VHe9395a780f86f7653c9f11cadba1e3f0#
 CM <- local({ # _C_hecked _M_odule
+  # 2025-07-11: [feature] New `manual_check` flag to tell `CM$generate_check_functions()` to ignore particular elements
+  # 2025-04-09: [fix] Make `generate_map_afmm_function` maps multi-variable parameters (e.g. `visit_vars`)
   # 2025-03-21: [feature] report errors for all loaded datasets and [fix] dehardcode "PARAM" string and use `par` argument
 
   message_well <- function(title, contents, color = "f5f5f5") {
@@ -281,6 +283,13 @@ CM <- local({ # _C_hecked _M_odule
       elem <- spec$elements[[elem_name]]
       attrs_ids <- setdiff(names(attributes(elem)), c("names", "docs"))
       attrs <- attributes(elem)[attrs_ids]
+      
+      if (isTRUE(attrs[["manual_check"]])) {
+        push(sprintf("'NOTE: %s (%s) tagged as \"manual_check\"'\n", elem_name, elem$kind))
+        push(sprintf("'      The expectation is that it either does not require automated checks or that'\n"))
+        push(sprintf("'      the caller of this function has written manual checks near the call site.'\n"))
+        next
+      }
 
       if (isTRUE(attrs[["subjid_var"]])) {
         subjid_vars <- c(subjid_vars, elem_name)
@@ -320,6 +329,11 @@ CM <- local({ # _C_hecked _M_odule
           "OK[['%s']] <- CM$check_function('%s', %s, %d, flags, warn, err)\n",
           elem_name, elem_name, elem_name, elem$arg_count
         ))
+      } else if (elem$kind == "group") {
+        push(sprintf("'NOTE: %s (%s) unsupported as the check generator cannot handle nested elements yet'\n",
+                     elem_name, elem$kind))
+        push(sprintf("'      The expectation is that it either does not require automated checks or that'\n"))
+        push(sprintf("'      the caller of this function has written manual checks near the call site.'\n"))
       } else {
         push(sprintf("'NOTE: %s (%s) has no associated automated checks'\n", elem_name, elem$kind))
         push(sprintf("'      The expectation is that it either does not require them or that'\n"))
@@ -422,11 +436,24 @@ CM <- local({ # _C_hecked _M_odule
         elem <- spec$elements[[elem_name]]
         stopifnot(elem$kind == "col")
         dataset_name <- elem[["dataset_name"]]
-        push(sprintf("if(is.character(ds[[%s]][[%s]])){\n", dataset_name, elem_name))
-        push("mapping_summary <- c(mapping_summary,")
-        push(sprintf("paste0('(', ds_name, ') ', %s, '[[\"', %s, '\"]]')", dataset_name, elem_name))
-        push(")\n")
-        push("}\n")
+        
+        multiple <- (isTRUE(attr(elem, "zero_or_more")) || isTRUE(attr(elem, "one_or_more")))
+        if (multiple) {
+          push(sprintf("for (.elem in %s) {\n", elem_name))
+          push(sprintf("if(is.character(ds[[%s]][[.elem]])){\n", dataset_name))
+          push("mapping_summary <- c(mapping_summary,")
+          push(sprintf("paste0('(', ds_name, ') ', %s, '[[\"', .elem, '\"]]')", dataset_name))
+          push(")\n")
+          push("}\n")
+          push("}\n")
+        } else {
+          push(sprintf("if(is.character(ds[[%s]][[%s]])){\n", dataset_name, elem_name))
+          push("mapping_summary <- c(mapping_summary,")
+          push(sprintf("paste0('(', ds_name, ') ', %s, '[[\"', %s, '\"]]')", dataset_name, elem_name))
+          push(")\n")
+          push("}\n")
+        }
+        
       }
       push("}\n")
 
@@ -449,10 +476,20 @@ CM <- local({ # _C_hecked _M_odule
         elem <- spec$elements[[elem_name]]
         dataset_name <- elem[["dataset_name"]]
 
-        push(sprintf("if (is.character(res[[%s]][[%s]])) {\n", dataset_name, elem_name))
-        push(sprintf("  res[[%s]][[%s]] <- ", dataset_name, elem_name))
-        push(sprintf("    as.factor(res[[%s]][[%s]])\n", dataset_name, elem_name))
-        push("}\n")
+        multiple <- (isTRUE(attr(elem, "zero_or_more")) || isTRUE(attr(elem, "one_or_more")))
+        if (multiple) {
+          push(sprintf("for (.elem in %s) {\n", elem_name))
+          push(sprintf("if (is.character(res[[%s]][[.elem]])) {\n", dataset_name))
+          push(sprintf("  res[[%s]][[.elem]] <- ", dataset_name))
+          push(sprintf("    as.factor(res[[%s]][[.elem]])\n", dataset_name))
+          push("}\n")
+          push("}\n")
+        } else {
+          push(sprintf("if (is.character(res[[%s]][[%s]])) {\n", dataset_name, elem_name))
+          push(sprintf("  res[[%s]][[%s]] <- ", dataset_name, elem_name))
+          push(sprintf("    as.factor(res[[%s]][[%s]])\n", dataset_name, elem_name))
+          push("}\n")
+        }
       }
 
       push("  return(res)\n")

R/TC.R

@@ -1,4 +1,4 @@
-# YT#VH1202cc468f3cbf448dd25ff917fc4762#VH00000000000000000000000000000000#
+# YT#VHf29a3f572c107632b46daf31f56ecd34#VH1202cc468f3cbf448dd25ff917fc4762#
 TC <- local({ # _T_ype C_hecks
   # basic types
   T_logical <- function() list(kind = "logical")
@@ -78,6 +78,7 @@ TC <- local({ # _T_ype C_hecks
         "named",                      # elements of targetted argument must be named
         "map_character_to_factor",    # the target TC$col() will be transformed to factor prior to reaching the module
         "ignore",                     # argument should be ignored by Dressing Room, for now
+        "manual_check",               # CM$generate_check_functions will not generate an automated check for this element
         # domain-specific flags
         "subject_level_dataset_name", # indicates dataset with one row per subject
         "subjid_var"                  # indicates unique subject identifier column on dataset pointed at by subject_level_dataset_name 

R/check_call_auto.R

@@ -5,7 +5,8 @@
 # dv.edish::mod_edish
 check_mod_edish_auto <- function(afmm, datasets, module_id, subject_level_dataset_name, lab_dataset_name,
     subjectid_var, arm_var, arm_default_vals, visit_var, baseline_visit_val, lb_test_var, lb_test_choices,
-    lb_test_default_x_val, lb_test_default_y_val, lb_result_var, ref_range_upper_lim_var, receiver_id, warn, err) {
+    lb_test_default_x_val, lb_test_default_y_val, lb_result_var, ref_range_upper_lim_var, receiver_id,
+    warn, err) {
     OK <- logical(0)
     used_dataset_names <- new.env(parent = emptyenv())
     OK[["module_id"]] <- CM$check_module_id("module_id", module_id, warn, err)
@@ -24,10 +25,9 @@ check_mod_edish_auto <- function(afmm, datasets, module_id, subject_level_datase
     flags <- structure(list(), names = character(0))
     OK[["arm_var"]] <- OK[["subject_level_dataset_name"]] && CM$check_dataset_colum_name("arm_var", arm_var,
         subkind, flags, subject_level_dataset_name, datasets[[subject_level_dataset_name]], warn, err)
-    flags <- list(one_or_more = TRUE, optional = TRUE)
-    OK[["arm_default_vals"]] <- OK[["arm_var"]] && CM$check_choice_from_col_contents("arm_default_vals",
-        arm_default_vals, flags, "subject_level_dataset_name", datasets[[subject_level_dataset_name]],
-        arm_var, warn, err)
+    "NOTE: arm_default_vals (choice_from_col_contents) tagged as \"manual_check\""
+    "      The expectation is that it either does not require automated checks or that"
+    "      the caller of this function has written manual checks near the call site."
     subkind <- list(kind = "or", options = list(list(kind = "character"), list(kind = "factor")))
     flags <- structure(list(), names = character(0))
     OK[["visit_var"]] <- OK[["lab_dataset_name"]] && CM$check_dataset_colum_name("visit_var", visit_var,
@@ -61,6 +61,9 @@ check_mod_edish_auto <- function(afmm, datasets, module_id, subject_level_datase
     OK[["ref_range_upper_lim_var"]] <- OK[["lab_dataset_name"]] && CM$check_dataset_colum_name("ref_range_upper_lim_var",
         ref_range_upper_lim_var, subkind, flags, lab_dataset_name, datasets[[lab_dataset_name]], warn,
         err)
+    "NOTE: receiver_id (character) has no associated automated checks"
+    "      The expectation is that it either does not require them or that"
+    "      the caller of this function has written manual checks near the call site."
     for (ds_name in names(used_dataset_names)) {
         OK[["subjectid_var"]] <- OK[["subjectid_var"]] && CM$check_subjid_col(datasets, ds_name, get(ds_name),
             "subjectid_var", subjectid_var, warn, err)

R/mod_edish.R

@@ -465,7 +465,7 @@ mod_edish_API_spec <- TC$group(
   lab_dataset_name = TC$dataset_name(),
   subjectid_var = TC$col("subject_level_dataset_name", TC$or(TC$character(), TC$factor())) |> TC$flag("subjid_var"),
   arm_var = TC$col("subject_level_dataset_name", TC$or(TC$character(), TC$factor())),
-  arm_default_vals = TC$choice_from_col_contents("arm_var") |> TC$flag("one_or_more", "optional"),
+  arm_default_vals = TC$choice_from_col_contents("arm_var") |> TC$flag("one_or_more", "optional", "manual_check"),
   visit_var = TC$col("lab_dataset_name", TC$or(TC$character(), TC$factor())),
   baseline_visit_val = TC$choice_from_col_contents("visit_var"),
   lb_test_var = TC$col("lab_dataset_name", TC$or(TC$character(), TC$factor())),