feat: added a formatting function for the output of data_extract_srv

DESCRIPTION

@@ -43,6 +43,7 @@ Suggests:
     rmarkdown,
     scda.2021(>= 0.1.3),
     scda(>= 0.1.3),
+    shinytest,
     testthat (>= 2.0)
 VignetteBuilder:
     knitr

NAMESPACE

@@ -39,6 +39,7 @@ export(data_merge_module)
 export(data_merge_srv)
 export(datanames_input)
 export(filter_spec)
+export(format_data_extract)
 export(get_anl_relabel_call)
 export(get_dataset_prefixed_col_names)
 export(get_extract_datanames)
@@ -59,4 +60,5 @@ export(variable_choices)
 import(shiny)
 importFrom(formatters,var_labels)
 importFrom(formatters,var_relabel)
+importFrom(lifecycle,badge)
 importFrom(magrittr,"%>%")

NEWS.md

@@ -1,5 +1,8 @@
 # teal.transform 0.1.0.9008
 
+### New features
+* Added a formatting function for the output of `data_extract_srv` - `format_data_extract`.
+
 ### Breaking changes
 * Removed the (previously deprecated) `input_id` argument to `data_merge_module`.
 * All `selected` values must be valid `choices` when calling `choices_selected`. When using delayed resolving the invalid selected are removed and a warning is thrown to the logs, in other cases an error is thrown.

R/data_extract_module.R

@@ -358,7 +358,6 @@ data_extract_srv <- function(id, datasets, data_extract_spec) {
         return(reactive(NULL))
       }
       check_data_extract_spec(data_extract_spec = data_extract_spec)
-
       res <- tryCatch(
         check_data_extract_spec_react(datasets, data_extract_spec),
         error = function(e) shiny::reactive(shiny::validate(e$message))

R/format_data_extract.R

@@ -0,0 +1,75 @@
+#' @title Formatting data extracts
+#' @description Returns a human-readable string representation of an extracted `data_extract_spec` object.
+#'
+#' @details
+#' This function formats the output of [`data_extract_srv`]. See the example for more information.
+#'
+#' @param data_extract `list` the list output of `data_extract_srv`
+#' @return `character(1)` the string representation
+#' @examples
+#' simple_des <- data_extract_spec(
+#'   dataname = "iris",
+#'   filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
+#'   select = select_spec(choices = c("Petal.Length", "Species"))
+#' )
+#'
+#' sample_filtered_data <- {
+#'   # create TealData
+#'   data <- teal.data::teal_data(teal.data::dataset("iris", iris))
+#'
+#'   # covert TealData to FilteredData
+#'   datasets <- teal.slice:::filtered_data_new(data)
+#'   teal.slice:::filtered_data_set(data, datasets)
+#'   datasets
+#' }
+#'
+#' if (interactive()) {
+#'   shiny::shinyApp(
+#'     ui = shiny::fluidPage(
+#'       data_extract_ui(
+#'         id = "extract",
+#'         label = "data extract ui",
+#'         data_extract_spec = simple_des,
+#'         is_single_dataset = TRUE
+#'       ),
+#'       shiny::verbatimTextOutput("formatted_extract")
+#'     ),
+#'     server = function(input, output, session) {
+#'       extracted_input <- data_extract_srv(
+#'         id = "extract",
+#'         datasets = sample_filtered_data,
+#'         data_extract_spec = simple_des
+#'       )
+#'       output$formatted_extract <- shiny::renderPrint({
+#'         cat(format_data_extract(extracted_input()))
+#'       })
+#'     }
+#'   )
+#' }
+#' @export
+#'
+format_data_extract <- function(data_extract) {
+  if (is.null(data_extract)) {
+    return(NULL)
+  }
+
+  checkmate::assert_list(data_extract)
+  required_names <- c("select", "filters", "dataname")
+  if (!checkmate::test_subset(required_names, choices = names(data_extract))) {
+    stop(sprintf("data_extract must be a named list with names: %s", paste0(required_names, collapse = " ")))
+  }
+
+  out <- sprintf("<Data Extract for dataset: %s>", data_extract$dataname)
+  out <- c(out, "Filters:")
+  for (filter in data_extract$filters) {
+    filtering_columns <- paste0(filter$columns, collapse = " ")
+    selected_values <- paste0(filter$selected, collapse = " ")
+    out <- c(out, sprintf("  Columns: %s Selected: %s", filtering_columns, selected_values))
+  }
+
+  out <- c(out, "Selected columns:")
+  selected_columns <- paste0(data_extract$select, collapse = " ")
+  out <- c(out, sprintf("  %s", selected_columns))
+
+  paste0(out, collapse = "\n")
+}

R/teal.transform-package.R

@@ -5,4 +5,5 @@
 #' @import shiny
 #' @importFrom magrittr %>%
 #' @importFrom formatters var_relabel var_labels
+#' @importFrom lifecycle badge
 NULL

_pkgdown.yml

@@ -5,12 +5,12 @@ template:
   package: nesttemplate
 
 articles:
-- title: Articles
-  navbar: ~
-  contents:
-  - data-extract
-  - data-extract-merge
-  - data-merge
+  - title: Articles
+    navbar: ~
+    contents:
+      - data-extract
+      - data-extract-merge
+      - data-merge
 
 navbar:
   right:
@@ -52,3 +52,6 @@ reference:
       - is_single_dataset
       - list_extract_spec
       - merge_datasets
+  - title: Human-readable formatting of a data extract object
+    contents:
+      - format_data_extract

tests/testthat/setup-skip_if_too_deep.R

@@ -0,0 +1,52 @@
+#' Returns testing depth set by an environmental variable.
+#'
+#' @details Looks for the option `TESTING_DEPTH` first, if not set,
+#' takes the system environmental variable `TESTING_DEPTH`. If neither
+#' is set, then returns 3 by default. If the value of `TESTING_DEPTH`
+#' is not a scalar numeric, then returns 3.
+#'
+#' @return `numeric(1)` the testing depth.
+#'
+testing_depth <- function() { # nolint # nousage
+  testing_depth <- getOption("TESTING_DEPTH")
+  if (is.null(testing_depth)) testing_depth <- Sys.getenv("TESTING_DEPTH")
+
+  testing_depth <- tryCatch(
+    as.numeric(testing_depth),
+    error = function(error) 3,
+    warning = function(warning) 3
+  )
+
+  if (length(testing_depth) != 1 || is.na(testing_depth)) testing_depth <- 3
+
+  testing_depth
+}
+
+#' Skipping tests in the testthat pipeline under specific scope
+#' @description This function should be used per each \code{testthat::test_that} call.
+#'   Each of the call should specify an appropriate depth value.
+#'   The depth value will set the appropriate scope so more/less time consuming tests could be recognized.
+#'   The environment variable \code{TESTING_DEPTH} is used for changing the scope of \code{testthat} pipeline.
+#' \code{TESTING_DEPTH} interpretation for each possible value:
+#' \itemize{
+#' \item{0}{no tests at all}
+#' \item{1}{fast - small scope - executed on every commit}
+#' \item{3}{medium - medium scope - daily integration pipeline}
+#' \item{5}{slow - all tests - daily package tests}
+#' }
+#' @param depth \code{numeric} the depth of the testing evaluation,
+#'   has opposite interpretation to environment variable \code{TESTING_DEPTH}.
+#'   So e.g. `0` means run it always and `5` means a heavy test which should be run rarely.
+#'   If the \code{depth} argument is larger than \code{TESTING_DEPTH} then the test is skipped.
+#' @importFrom testthat skip
+#' @return \code{NULL} or invoke an error produced by \code{testthat::skip}
+#' @note By default \code{TESTING_DEPTH} is equal to 3 if there is no environment variable for it.
+#' By default \code{depth} argument lower or equal to 3 will not be skipped because by default \code{TESTING_DEPTH}
+#' is equal to 3. To skip <= 3 depth tests then the environment variable has to be lower than 3 respectively.
+skip_if_too_deep <- function(depth) { # nolintr
+  checkmate::assert_number(depth, lower = 0, upper = 5)
+  test_to_depth <- testing_depth() # by default 3 if there are no env variable
+  if (test_to_depth < depth) {
+    testthat::skip(paste("testing depth", test_to_depth, "is below current testing specification", depth))
+  }
+}

tests/testthat/shinytest/format_data_extract/app.R

@@ -0,0 +1,25 @@
+simple_des <- teal.transform::data_extract_spec(
+  dataname = "iris",
+  filter = teal.transform::filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
+  select = teal.transform::select_spec(choices = c("Petal.Length", "Species"))
+)
+
+sample_filtered_data <- {
+  data <- teal.data::teal_data(teal.data::dataset("iris", iris))
+  datasets <- teal.slice:::filtered_data_new(data)
+  teal.slice:::filtered_data_set(data, datasets)
+  datasets
+}
+
+ui <- shiny::fluidPage(
+  teal.transform::data_extract_ui(id = "des", label = "test des ui", data_extract_spec = simple_des),
+  shiny::verbatimTextOutput(outputId = "formatted_des"),
+)
+srv <- function(input, output, session) {
+  extracted_des <- teal.transform::data_extract_srv(
+    id = "des", datasets = sample_filtered_data, data_extract_spec = simple_des
+  )
+  output$formatted_des <- shiny::renderPrint(cat(teal.transform::format_data_extract(extracted_des())))
+}
+
+shiny::shinyApp(ui, srv)

tests/testthat/shinytest/format_data_extract/tests/shinytest/test-expected/001.json

@@ -0,0 +1,5 @@
+{
+  "output": {
+    "formatted_des": "<Data Extract for dataset: iris>\nFilters:\n  Columns: Petal.Length Selected: 1.4\nSelected columns:\n  Petal.Length"
+  }
+}

tests/testthat/shinytest/format_data_extract/tests/shinytest/test-expected/002.json

@@ -0,0 +1,5 @@
+{
+  "output": {
+    "formatted_des": "<Data Extract for dataset: iris>\nFilters:\n  Columns:  Selected: \nSelected columns:\n  Petal.Length"
+  }
+}

tests/testthat/shinytest/format_data_extract/tests/shinytest/test-expected/003.json

@@ -0,0 +1,5 @@
+{
+  "output": {
+    "formatted_des": "<Data Extract for dataset: iris>\nFilters:\n  Columns: Petal.Length Selected: 4.7\nSelected columns:\n  Species"
+  }
+}

tests/testthat/shinytest/format_data_extract/tests/shinytest/test.R

@@ -0,0 +1,10 @@
+app <- ShinyDriver$new("../../")
+app$snapshotInit("test")
+
+app$snapshot(list(output = "formatted_des"))
+app$setInputs(`des-dataset_iris_singleextract-filter1-col` = character(0))
+app$snapshot(list(output = "formatted_des"))
+app$setInputs(`des-dataset_iris_singleextract-filter1-col` = "Petal.Length")
+app$setInputs(`des-dataset_iris_singleextract-filter1-vals` = "4.7")
+app$setInputs(`des-dataset_iris_singleextract-select` = "Species")
+app$snapshot(list(output = "formatted_des"))

tests/testthat/test-format_data_extract.R

@@ -0,0 +1,64 @@
+required_names <- c("select", "filters", "dataname")
+
+testthat::test_that("format_data_extract is a function that accepts a list", {
+  data_extract_fake <- as.list(stats::setNames(nm = required_names))
+  data_extract_fake$filters <- list()
+  testthat::expect_error(format_data_extract(data_extract_fake), regexp = NA)
+})
+
+testthat::test_that("format_data_extract asserts its argument has required names", {
+  testthat::expect_error(
+    format_data_extract(list()),
+    regexp = "data_extract must be a named list with names: select filters dataname"
+  )
+})
+
+testthat::test_that("format_data_extract returns a string representation of the extracted data", {
+  data_extract_fake <- as.list(stats::setNames(nm = required_names))
+  data_extract_fake$dataname <- "test dataname"
+  data_extract_fake$filters <- list(list(columns = c("ColA", "ColB"), selected = "ColB"))
+  data_extract_fake$select <- c("ColC", "ColD")
+  data_extract_fake
+
+  testthat::expect_equal(
+    format_data_extract(data_extract_fake),
+    paste(
+      "<Data Extract for dataset: test dataname>",
+      "Filters:",
+      "  Columns: ColA ColB Selected: ColB",
+      "Selected columns:",
+      "  ColC ColD",
+      sep = "\n"
+    )
+  )
+})
+
+testthat::test_that("format_data_extract integrates with data_extract_srv", {
+  sample_filtered_data <- {
+    data <- teal.data::teal_data(teal.data::dataset("iris", iris))
+    datasets <- teal.slice:::filtered_data_new(data)
+    teal.slice:::filtered_data_set(data, datasets)
+    datasets
+  }
+
+  simple_des <- data_extract_spec(
+    dataname = "iris",
+    filter = filter_spec(vars = "Petal.Length", choices = c("1.4", "1.5")),
+    select = select_spec(choices = c("Petal.Length", "Species"))
+  )
+
+  shiny::testServer(
+    data_extract_srv,
+    args = list(data_extract_spec = simple_des, datasets = sample_filtered_data),
+    expr = {
+      testthat::expect_error(format_data_extract(session$returned()), regexp = NA)
+    }
+  )
+})
+
+testthat::test_that("format_data_extract integrates with data_extract_srv and the filtered data object", {
+  skip_if_too_deep(4)
+  shinytest::expect_pass(
+    shinytest::testApp(testthat::test_path("shinytest/format_data_extract"), compareImages = FALSE)
+  )
+})