Merge pull request #66 from Boehringer-Ingelheim/358964-extendable_review_options

358964 extendable review options

Author: ml-ebs-ext

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: dv.listings
 Type: Package
 Title: Data listings module
-Version: 4.3.4-9000
+Version: 4.3.4-9001
 Authors@R: 
     c(
       person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),

NEWS.md

@@ -1,3 +1,7 @@
+# dv.listings 4.3.4-9001
+- Review functionality:
+  - Allow expanding review choices
+
 # dv.listings 4.3.4-9000
 - [NOT USER-FACING] Update CM.R snippet
 

R/review.R

@@ -198,16 +198,38 @@ REV_load_annotation_info <- function(folder_contents, review, dataset_lists) {
       contents <- folder_contents[[file_path]]
       review_info <- RS_parse_review_codes(contents)
       if (!identical(review_info, review[["choices"]])) {
-        error <- c(
-          error, 
-          paste0(
-            "Review choices should remain stable during the course of a trial.\n",
-            "The original review choices are: ", paste(sprintf('"%s"', review_info), collapse = ", "), ".\n",
-            "This restriction is likely to be lifted in a future revision of the review feature."
+        # See if the new reviews can be appended cleanly to the old ones
+        new_contents <- RS_compute_review_codes_memory(review[["choices"]])
+        new_review_options_extend_old_ones <- (length(contents) < length(new_contents) && 
+                                                 identical(contents, new_contents[seq_along(contents)]))
+        if (new_review_options_extend_old_ones) {
+          epilogue <- new_contents[(length(contents) + 1):length(new_contents)]
+          append_IO_action(list(kind = "write", path = file_path, contents = epilogue, offset = FS$WRITE_OFFSET_APPEND))
+        } else {
+          choices_diff_report <- local({
+            old_choices <- review_info
+            new_choices <- review[["choices"]]
+            max_len <- max(length(old_choices), length(new_choices))
+            length(old_choices) <- max_len
+            length(new_choices) <- max_len
+            df <- data.frame(`Old choices` = old_choices, `New choices` = new_choices, check.names = FALSE)
+            return(capture.output(print(df)))
+          })
+          undo_table_s <- paste0("<pre style='max-height: 12rem;'>", paste(choices_diff_report, collapse = "<br>"), "</pre>")
+          
+          error <- c(
+            error, 
+            paste0(
+              "Review choices cannot be removed or reordered during the course of a trial.<br>",
+              "Each choice has an associated integer value that should remain constant. These are the old and new ",
+              "review choices:<br>",
+              undo_table_s,
+              "The recommended action is to restore the previous review choices:<br>",
+              paste0("<pre>choices = c(", sprintf('"%s"', review_info) |> paste(collapse = ","), ")</pre>"),
+              "and append any extra desired choices at the end."
+            )
           )
-          # TODO: Combine new review[["choices"]] with old `review.codes`
-          #       while preserving original associated integer codes
-        )
+        }
       }
     } else {
       contents <- RS_compute_review_codes_memory(review[["choices"]])

inst/validation/specs.R

@@ -39,6 +39,7 @@ review <- specs_list(
   , review_reject_storage_subfolders = "review feature rejects selection of child storage subfolders"
   , review_reject_conflicting_connect_app_storage = "review feature rejects selection of storage folder initially created by a different Posit Connect app"
   , review_undo = "review feature allows per-role undoing of latest reviews"
+  , review_allow_extension_of_review_options = "review feature allows the extension of review options in ongoing trials"
 )
 # nolint end line_length_linter
 

tests/testthat/test-review.R

@@ -136,6 +136,24 @@ local({
     fs_client[["execute_IO_plan"]](info[["IO_plan"]])
     expect_identical(fs_contents[["dataset_list/ae_roleA.review"]][[zero_based_version_byte_pos+1L]], as.raw(1L))
   })
+  
+  test_that("REV_load_annotation_info rejects all changes to `choices` except for pure append actions" |>
+              vdoc[["add_spec"]](specs$review_allow_extension_of_review_options), {
+    incorrect_review_config <- review
+    incorrect_review_config[["choices"]] <- head(incorrect_review_config[["choices"]], 1) # discard all but first choice
+    info <- REV_load_annotation_info(fs_contents, incorrect_review_config, dataset_lists)
+    expect_length(info[["error"]], 1)
+   
+    correct_review_config <- review
+    correct_review_config[["choices"]] <- c(correct_review_config[["choices"]], "extra review choice")
+    info <- REV_load_annotation_info(fs_contents, correct_review_config, dataset_lists)
+    expect_length(info[["error"]], 0)
+    expect_length(info[["IO_plan"]], 1)
+    action <- info[["IO_plan"]][[1]]
+    expect_true(
+      action[["kind"]] == 'write' && action[["path"]] == 'dataset_list/review.codes' && action[["offset"]] == -1L
+    )
+  })
 })
 
 local({

tests/testthat/test-review_invariants.R

@@ -34,12 +34,13 @@ local({
   fs_client[["execute_IO_plan"]](info[["IO_plan"]])
   expect_length(fs_state[["error"]], 0L)
 
-  test_that("Review error message when extra choice is provided", {
+  test_that("Review error message when extra choice is provided in a non-trailing position", {
     review2 <- review
-    review2[["choices"]] <- c(review2[["choices"]], "choiceC")
+    review2[["choices"]] <- c("choiceC", review2[["choices"]])
     info <- REV_load_annotation_info(fs_contents, review2, dataset_lists)
     expect_true(length(info[["error"]]) == 1 &&
-                  startsWith(info[["error"]][[1]], "Review choices should remain stable during the course of a trial."))
+                  startsWith(info[["error"]][[1]], 
+                             "Review choices cannot be removed or reordered during the course of a trial."))
   })
 
   test_that("Review error message when `id_vars` is modified", {