333 version script@main (#681)

create a simple template --------- Signed-off-by: Liming <[email protected]> Signed-off-by: b_falquet <[email protected]> Co-authored-by: benoit <[email protected]> Co-authored-by: b_falquet <[email protected]>
insightsengineering · Oct 27, 2023 · a184ef2 · a184ef2
1 parent cc70064
commit a184ef2
Show file tree

Hide file tree

Showing 13 changed files with 157 additions and 29 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -84,6 +84,7 @@ Collate:
     'dmt01.R'
     'dst01.R'
     'dtht01.R'
+    'dummy_template.R'
     'egt01.R'
     'egt02.R'
     'egt03.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -57,6 +57,7 @@ export(cfbt01_post)
 export(cfbt01_pre)
 export(chevron_g)
 export(chevron_l)
+export(chevron_simple)
 export(chevron_t)
 export(cmt01_label)
 export(cmt01a)
@@ -86,6 +87,7 @@ export(dtht01)
 export(dtht01_main)
 export(dtht01_post)
 export(dtht01_pre)
+export(dummy_template)
 export(egt01)
 export(egt01_main)
 export(egt01_pre)
@@ -215,6 +217,7 @@ export(vst02_pre)
 export(with_label)
 exportClasses(chevron_g)
 exportClasses(chevron_l)
+exportClasses(chevron_simple)
 exportClasses(chevron_t)
 exportClasses(chevron_tlg)
 exportMethods("main<-")

diff --git a/NEWS.md b/NEWS.md
@@ -1,6 +1,8 @@
 # chevron 0.2.4.9002
 
 * `MNG01` plot can now be displayed without error bars and can display a continuous temporal scale on the `x` axis.
+* Add a `chevron_simple` class only contain main function.
+* Remove `details` argument in `script_funs`, add `name` argument.
 
 # chevron 0.2.4
 

diff --git a/R/chevron_tlg-S4class.R b/R/chevron_tlg-S4class.R
@@ -63,12 +63,6 @@ methods::setValidity("chevron_tlg", function(object) {
   contains = "chevron_tlg"
 )
 
-methods::setValidity("chevron_t", function(object) {
-  coll <- makeAssertCollection()
-  assert_function(object@main, args = c("adam_db"), ordered = TRUE, add = coll)
-  reportAssertions(coll)
-})
-
 ## chevron_l ----
 
 #' `chevron_l`
@@ -83,12 +77,6 @@ methods::setValidity("chevron_t", function(object) {
   contains = "chevron_tlg"
 )
 
-methods::setValidity("chevron_l", function(object) {
-  coll <- makeAssertCollection()
-  assert_function(object@main, args = c("adam_db"), ordered = TRUE, add = coll)
-  reportAssertions(coll)
-})
-
 ## chevron_g ----
 
 #' `chevron_g`
@@ -103,13 +91,35 @@ methods::setValidity("chevron_l", function(object) {
   contains = "chevron_tlg"
 )
 
-methods::setValidity("chevron_g", function(object) {
-  coll <- makeAssertCollection()
-  assert_function(object@main, args = c("adam_db"), ordered = TRUE, add = coll)
-  reportAssertions(coll)
-})
+## chevron_simple ----
+
+#' `chevron_simple`
+#'
+#' `chevron_simple`, a subclass of [chevron::chevron_tlg-class], where main function is a simple call
+#'
+#' @aliases chevron_simple
+#' @rdname chevron_tlg-class
+#' @exportClass chevron_simple
+.chevron_simple <- setClass(
+  "chevron_simple",
+  contains = "chevron_tlg"
+)
 
 
+# Validity of class `chevron_simple`
+methods::setValidity("chevron_simple", function(object) {
+  main_body <- body(object@main)
+  if (is.symbol(main_body)) {
+    return(invisible(TRUE))
+  }
+  res <- rapply(to_list(main_body), function(x) {
+    identical(x, as.name("return"))
+  })
+  has_return <- if (any(res)) "Must be a simple expression without `return`" else TRUE
+  makeAssertion(object@main, has_return, var.name = "object@main", collection = NULL)
+  invisible(TRUE)
+})
+
 # Sub Constructor ----
 
 #' `chevron_t` constructor
@@ -193,3 +203,23 @@ chevron_g <- function(main = function(adam_db, ...) ggplot2::ggplot(),
 
   res
 }
+
+#' `chevron_simple` constructor
+#'
+#' @rdname chevron_tlg-class
+#' @param ... not used
+#'
+#' @inheritParams gen_args
+#'
+#' @export
+#'
+#' @examples
+#' chevron_simple_obj <- chevron_simple()
+chevron_simple <- function() {
+  res <- .chevron_simple(
+    main = \(adam_db, ...) basic_table() %>% build_table(data.frame()),
+    preprocess = \(adam_db, ...) adam_db,
+    postprocess = \(tlg, ...) tlg
+  )
+  res
+}
diff --git a/R/chevron_tlg-S4methods.R b/R/chevron_tlg-S4methods.R
@@ -322,7 +322,7 @@ setMethod(
 #'
 #' @param x (`chevron_tlg`) input.
 #' @param adam_db (`string`) the name of the dataset.
-#' @param details (`flag`) deprecated. Whether to show the code of all functions.
+#' @param name (`string`) name of the template.
 #' @param args (`string`) the name of argument list.
 #'
 #' @name script
@@ -335,7 +335,7 @@ NULL
 #'
 #' @rdname script
 #' @export
-setGeneric("script_funs", function(x, adam_db, args, details = FALSE) standardGeneric("script_funs"))
+setGeneric("script_funs", function(x, adam_db, args, name = deparse(substitute(x))) standardGeneric("script_funs"))
 
 #' @rdname script
 #' @export
@@ -345,23 +345,41 @@ setGeneric("script_funs", function(x, adam_db, args, details = FALSE) standardGe
 setMethod(
   f = "script_funs",
   signature = "chevron_tlg",
-  definition = function(x, adam_db, args, details) {
-    checkmate::assert_flag(details)
+  definition = function(x, adam_db, args, name) {
     checkmate::assert_string(adam_db)
     checkmate::assert_string(args)
-    if (!missing(details)) lifecycle::deprecate_warn("0.2.2", "chevron::script_funs(details = )")
-    tlg_name <- deparse(substitute(x))
-    checkmate::assert_string(tlg_name, pattern = "^[a-zA-Z]+\\w+$")
+    checkmate::assert_string(name)
     c(
       "# Edit Preprocessing Function.",
-      glue::glue("preprocess({tlg_name}) <- "),
+      glue::glue("preprocess({name}) <- "),
       deparse(preprocess(x), control = c("useSource")),
       "",
       "# Create TLG",
       glue::glue(
-        "tlg_output <- run(object = {tlg_name}, adam_db = {adam_db}",
+        "tlg_output <- run(object = {name}, adam_db = {adam_db}",
         ", verbose = TRUE, user_args = {args})"
       )
     )
   }
 )
+
+#' @rdname script
+#' @export
+#'
+setMethod(
+  f = "script_funs",
+  signature = "chevron_simple",
+  definition = function(x, adam_db, args, name) {
+    checkmate::assert_string(adam_db)
+    main_body <- body(main(x))
+    c(
+      "# Create TLG",
+      if (!identical(adam_db, "adam_db")) {
+        glue::glue("adam_db <- {adam_db}")
+      },
+      "",
+      "tlg_output <- ",
+      deparse(main_body)
+    )
+  }
+)
diff --git a/R/dummy_template.R b/R/dummy_template.R
@@ -0,0 +1,10 @@
+#' Dummy template.
+#'
+#' This template creates a dummy output.
+#'
+#' @include chevron_tlg-S4class.R
+#' @export
+#'
+#' @examples
+#' run(dummy_template, syn_data)
+dummy_template <- chevron_simple()
diff --git a/R/utils.R b/R/utils.R
@@ -379,3 +379,12 @@ set_section_div <- function(x) {
   options("chevron.section_div" = x)
   invisible()
 }
+
+#' @keywords internal
+to_list <- function(x) {
+  if (length(x) == 1L) {
+    return(x)
+  }
+  x <- as.list(x)
+  lapply(x, to_list)
+}
diff --git a/_pkgdown.yaml b/_pkgdown.yaml
@@ -95,6 +95,7 @@ reference:
       - vst01
       - vst02_1
       - vst02_2
+      - dummy_template
   - title: Data
     contents:
       - syn_data

diff --git a/man/chevron_tlg-class.Rd b/man/chevron_tlg-class.Rd
diff --git a/man/dummy_template.Rd b/man/dummy_template.Rd
diff --git a/man/script.Rd b/man/script.Rd
diff --git a/tests/testthat/test-chevron_tlg-class.R b/tests/testthat/test-chevron_tlg-class.R
@@ -160,3 +160,22 @@ test_that("chevron_g constructor returns an error when expected", {
     fixed = TRUE
   )
 })
+
+
+# chevron_simple ----
+
+test_that("chevron_simple works correctly", {
+  obj <- chevron_simple()
+  expect_silent(main(obj) <- \(adam_db, ...) abc)
+  expect_silent(main(obj) <- (\(adam_db, ...) {
+    abc
+  }))
+})
+
+test_that("chevron_simple errors if contains return", {
+  obj <- chevron_simple()
+  expect_error(
+    main(obj) <- \(adam_db, ...) return(abc),
+    "Must be a simple expression without `return`."
+  )
+})
diff --git a/tests/testthat/test-chevron_tlg-methods.R b/tests/testthat/test-chevron_tlg-methods.R
@@ -169,6 +169,11 @@ test_that("script_funs generates a valid script", {
   expect_identical(tlg_output, expected)
 })
 
+test_that("script_funs works for simple template", {
+  res <- expect_silent(script_funs(chevron_simple(), adam_db = "syn_data"))
+  expect_character(res)
+})
+
 # print_list ----
 
 test_that("print_list works", {