From a184ef283f4c8b7f482ed1939e12eb758e7d4669 Mon Sep 17 00:00:00 2001 From: Liming <36079400+clarkliming@users.noreply.github.com> Date: Fri, 27 Oct 2023 18:54:41 +0800 Subject: [PATCH] 333 version script@main (#681) create a simple template --------- Signed-off-by: Liming <36079400+clarkliming@users.noreply.github.com> Signed-off-by: b_falquet <64274616+BFalquet@users.noreply.github.com> Co-authored-by: benoit Co-authored-by: b_falquet <64274616+BFalquet@users.noreply.github.com> --- DESCRIPTION | 1 + NAMESPACE | 3 ++ NEWS.md | 2 + R/chevron_tlg-S4class.R | 64 +++++++++++++++++------ R/chevron_tlg-S4methods.R | 36 +++++++++---- R/dummy_template.R | 10 ++++ R/utils.R | 9 ++++ _pkgdown.yaml | 1 + man/chevron_tlg-class.Rd | 8 +++ man/dummy_template.Rd | 19 +++++++ man/script.Rd | 9 ++-- tests/testthat/test-chevron_tlg-class.R | 19 +++++++ tests/testthat/test-chevron_tlg-methods.R | 5 ++ 13 files changed, 157 insertions(+), 29 deletions(-) create mode 100644 R/dummy_template.R create mode 100644 man/dummy_template.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 637cbf125..b5f1b5c28 100755 --- 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 index 9cd731ec3..4d2138ad0 100644 --- 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 index bc9bcfbc7..7d4fee0ec 100644 --- 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 index 2c9d7b075..33aceca7e 100644 --- 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 index 4be8a8750..afa1b5be7 100644 --- 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 new file mode 100644 index 000000000..679d3775e --- /dev/null +++ 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 index c9f7774cf..cdf4788ba 100755 --- 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 index 5198f8ddf..9e5675e1f 100644 --- 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 index 1de865eda..02ee2984f 100644 --- a/man/chevron_tlg-class.Rd +++ b/man/chevron_tlg-class.Rd @@ -13,6 +13,9 @@ \alias{chevron_g-class} \alias{.chevron_g} \alias{chevron_graph} +\alias{chevron_simple-class} +\alias{.chevron_simple} +\alias{chevron_simple} \alias{chevron_t} \alias{chevron_l} \alias{chevron_g} @@ -38,6 +41,8 @@ chevron_g( postprocess = function(tlg, ...) tlg, ... ) + +chevron_simple() } \arguments{ \item{main}{(\code{function}) returning a \code{tlg}, with \code{adam_db} as first argument. Typically one of the \verb{_main} function @@ -56,6 +61,8 @@ Typically one of the \verb{_pre} function of \code{chevron}.} \code{chevron_l}, a subclass of \linkS4class{chevron_tlg} with specific validation criteria to handle listing creation \code{chevron_g}, a subclass of \linkS4class{chevron_tlg} with specific validation criteria to handle graph creation + +\code{chevron_simple}, a subclass of \linkS4class{chevron_tlg}, where main function is a simple call } \section{Slots}{ @@ -93,4 +100,5 @@ chevron_g_obj <- chevron_g( postprocess = function(tlg, title, ...) tlg + ggplot2::labs(main = title) ) +chevron_simple_obj <- chevron_simple() } diff --git a/man/dummy_template.Rd b/man/dummy_template.Rd new file mode 100644 index 000000000..a755ccf10 --- /dev/null +++ b/man/dummy_template.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dummy_template.R +\docType{data} +\name{dummy_template} +\alias{dummy_template} +\title{Dummy template.} +\format{ +An object of class \code{chevron_simple} of length 1. +} +\usage{ +dummy_template +} +\description{ +This template creates a dummy output. +} +\examples{ +run(dummy_template, syn_data) +} +\keyword{datasets} diff --git a/man/script.Rd b/man/script.Rd index cfc5e9afe..64cacd572 100644 --- a/man/script.Rd +++ b/man/script.Rd @@ -4,11 +4,14 @@ \alias{script} \alias{script_funs} \alias{script_funs,chevron_tlg-method} +\alias{script_funs,chevron_simple-method} \title{Create Script for Parameters Assignment} \usage{ -script_funs(x, adam_db, args, details = FALSE) +script_funs(x, adam_db, args, name = deparse(substitute(x))) -\S4method{script_funs}{chevron_tlg}(x, adam_db, args, details = FALSE) +\S4method{script_funs}{chevron_tlg}(x, adam_db, args, name = deparse(substitute(x))) + +\S4method{script_funs}{chevron_simple}(x, adam_db, args, name = deparse(substitute(x))) } \arguments{ \item{x}{(\code{chevron_tlg}) input.} @@ -17,7 +20,7 @@ script_funs(x, adam_db, args, details = FALSE) \item{args}{(\code{string}) the name of argument list.} -\item{details}{(\code{flag}) deprecated. Whether to show the code of all functions.} +\item{name}{(\code{string}) name of the template.} } \description{ Create Script for Parameters Assignment diff --git a/tests/testthat/test-chevron_tlg-class.R b/tests/testthat/test-chevron_tlg-class.R index bac932018..41bb3602f 100644 --- 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 index 7481c41e1..3cc9d8622 100644 --- 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", {