Merge pull request #471 from GSK-Biostatistics/mock-errors

small fixes for creating mock data

NEWS.md

@@ -1,5 +1,8 @@
 # tfrmt development version
 
+Improvements
+* Incorporate contents of `col_style_plan` in the creation of mock data. 
+
 Bug fixes
 * Fixed issue where JSON conversion of `frmt_when` dropped quotes from strings
 * Avoid use of deprecated functionality in `dplyr::summarise()`

R/mock_tbl.R

@@ -90,6 +90,7 @@ make_mock_data <- function(tfrmt, .default = 1:3, n_cols = NULL){
                          label = tfrmt$label,
                          sorting_cols = tfrmt$sorting_cols,
                          col_plan = tfrmt$col_plan,
+                         col_style_plan = tfrmt$col_style_plan,
                          n_cols = n_cols)
 
   output_dat <- output_dat %>%
@@ -166,7 +167,7 @@ add_sorting_cols <- function(data, sorting_cols){
   data
 }
 
-make_col_df <- function(column, group, label, sorting_cols, col_plan, n_cols){
+make_col_df <- function(column, group, label, sorting_cols, col_plan, col_style_plan, n_cols){
 
   column_vars <- column %>% map_chr(as_label)
   grp_lb_vars <- c(group %>% map_chr(as_name), as_label(label), sorting_cols %>% map_chr(as_name))
@@ -176,33 +177,54 @@ make_col_df <- function(column, group, label, sorting_cols, col_plan, n_cols){
 
   n_spans <- length(column_vars)
 
+  # test if col_plan/col_style_plan have names to use
+  col_plan_test_res <- col_plan_test(col_plan)
+  col_style_plan_test_res <- col_style_plan_test(col_style_plan)
+  col_def <- tibble()
+
   # Use provided column names if there is no spanning
-  if(col_plan_test(col_plan) & n_spans == 1 & is.null(n_cols)){
-    cols_to_use <- col_plan$dots %>%
-      clean_col_names(dont_inc = grp_lb_vars)
-    col_def <- tibble(!!column_vars[n_spans] := cols_to_use)
-  } else if(col_plan_test(col_plan) & is.null(n_cols)){
-    # Gets the lowest level columns only
-    low_lvl_vars <- col_plan$dots %>%
-      discard(is.list) %>%
-      clean_col_names(dont_inc = grp_lb_vars)
-
-    low_lvl_def <- tibble(!!column_vars[max(n_spans)] := low_lvl_vars)
-
-    # creates a df for each span structure
-    span_df <- col_plan$dots %>%
-      keep(is.list) %>%
-      map_dfr(function(x){
-        span_df <- x %>%
-          map(~clean_col_names(., c())) %>%
-          reduce(crossing) %>%
-          unnest(cols = everything())
-        names(span_df) <- names(x)
-        span_df
-      })
-    col_def <- bind_rows(low_lvl_def, span_df)
+  if (col_plan_test_res || col_style_plan_test_res){
+    if(col_plan_test_res & n_spans == 1 & is.null(n_cols)){
+      cols_to_use <- col_plan$dots %>%
+        clean_col_names(dont_inc = grp_lb_vars)
+      col_def <- tibble(!!column_vars[n_spans] := cols_to_use)
+    } else if(col_plan_test_res & is.null(n_cols)){
+      # Gets the lowest level columns only
+      low_lvl_vars <- col_plan$dots %>%
+        discard(is.list) %>%
+        clean_col_names(dont_inc = grp_lb_vars)
+
+      low_lvl_def <- tibble(!!column_vars[max(n_spans)] := low_lvl_vars)
+
+      # creates a df for each span structure
+      span_df <- col_plan$dots %>%
+        keep(is.list) %>%
+        map_dfr(function(x){
+          span_df <- x %>%
+            map(~clean_col_names(., c())) %>%
+            reduce(crossing) %>%
+            unnest(cols = everything())
+          names(span_df) <- names(x)
+          span_df
+        })
+
+      col_def <- bind_rows(low_lvl_def, span_df)
 
-  } else {
+    }
+
+    # get col_style_plan referenced cols
+    if (col_style_plan_test_res){
+      cols_from_sp <- map(col_style_plan, ~.x$cols)  |>
+        list_flatten() |>
+        clean_col_names(dont_inc = grp_lb_vars)  %>%
+        tibble(.)
+      names(cols_from_sp) <- last(column_vars)
+
+      col_def <- bind_rows(col_def, cols_from_sp) |> unique()
+    }
+
+  }
+  else {
     n_cols <- ifelse(is.null(n_cols), 3, n_cols)
     col_def <- tibble(!!column_vars[n_spans] := paste0(column_vars[[n_spans]], seq(1:n_cols)))
     if(n_spans > 1){
@@ -212,6 +234,8 @@ make_col_df <- function(column, group, label, sorting_cols, col_plan, n_cols){
       col_def <- bind_cols(col_spans_df, col_def)
     }
   }
+
+
   col_def
 }
 
@@ -242,3 +266,17 @@ col_plan_test <- function(col_plan){
   }
   out
 }
+
+
+# check the col_style_plan contains something besides `everything()`
+col_style_plan_test <- function(col_style_plan){
+  if(is.null(col_style_plan)){
+    out <- FALSE
+  } else {
+    all_names <- map(col_style_plan, ~.x$cols)  |>
+      list_flatten() %>%
+      map_chr(as_label)
+    out <- !all("everything()" %in% all_names)
+  }
+  out
+}

inst/create_json_example_tfrmts.R

@@ -24,7 +24,11 @@ tfrmt_demog <- tfrmt(
   ),
 
   col_plan = col_plan(-grp,
-                      -starts_with("ord")
+                      -starts_with("ord"),
+                      rowlbl1,
+                      rowlbl2,
+                      "Placebo", "Xanomeline Low Dose",
+                      "Xanomeline High Dose", "Total", "p-value"
   )
   ,
   col_style_plan = col_style_plan(

inst/json_examples/tfrmt_demog.json

@@ -148,7 +148,14 @@
     "col_plan": {
       "dots": [
         ["-grp"],
-        ["-starts_with(\"ord\")"]
+        ["-starts_with(\"ord\")"],
+        ["rowlbl1"],
+        ["rowlbl2"],
+        ["Placebo"],
+        ["Xanomeline Low Dose"],
+        ["Xanomeline High Dose"],
+        ["Total"],
+        ["p-value"]
       ],
       ".drop": [false]
     }

tests/testthat/test-make_mock_data.R

@@ -617,6 +617,62 @@ test_that("Using col_plan to get column names", {
 
 })
 
+test_that("Using col_style_plan to get names",{
+
+  basic_cols <- tfrmt(
+    group = "group",
+    label = "label",
+    column = "column",
+    param = "param",
+    value = "value",
+    sorting_cols = c(ord1, ord2),
+    body_plan = body_plan(
+      frmt_structure(group_val = ".default", label_val = ".default", frmt("X.X"))
+    ),
+    col_style_plan = col_style_plan(
+      col_style_structure(align = ".", col = starts_with("Active")),
+      col_style_structure(align = " ", col = c("Placebo","Total"))
+    )
+  )
+
+  col_names <- make_mock_data(basic_cols) %>%
+    pull(column) %>%
+    unique()
+  expect_equal(col_names, c("Active","Placebo","Total"))
+
+
+  # combination col_style_plan/col_plan
+  auto_col_df <- tfrmt(
+    group = group,
+    label = quo(label),
+    param = parm,
+    column = c(test1,test2),
+    body_plan = body_plan(
+      frmt_structure(group_val = ".default", label_val = ".default", frmt("X.X"))
+    ),
+    col_plan = col_plan(
+      group,
+      label,
+      col4,
+      span_structure(test1 = `span 1`, test2 = c(col1, contains("col2"))),
+      span_structure(test1 = `span 2`, test2 = c(col7, col8)),
+      col3,
+      -col5
+    ),
+    col_style_plan = col_style_plan(
+      col_style_structure(align = ".", col = starts_with("Active")),
+      col_style_structure(align = " ", col = c("Placebo","Total"))
+    )
+  ) %>%
+    make_mock_data() %>%
+    select(test1, test2) %>%
+    distinct(test1, test2)
+
+  man_col_df <- tibble(test1 = c(rep(NA, 3), rep(c("span 1", "span 2"), each = 2), rep(NA, 3)),
+                       test2 = c("col4","col3", "col5", "col1", "col2", "col7","col8", "Active","Placebo","Total"))
+  expect_equal(auto_col_df, man_col_df)
+})
+
 test_that("Will add big N avaliable", {
   pop_tbl_tfrmt <- tfrmt(
     column = TRT01A,