From b16384a4d0445ed5d3d858a94bb74c86117659be Mon Sep 17 00:00:00 2001 From: shajoezhu Date: Mon, 11 Nov 2024 11:55:49 +0800 Subject: [PATCH] update --- R/drtable.R | 21 +++++++ R/fastdocall.R | 52 +++++++++++++++++ R/func_wrapper.R | 53 +++++++++++++++++ R/generate_output.R | 135 ++++++++++++++++++++++++++++++++++++++++++++ R/log.R | 41 ++++++++++++++ inst/WORDLIST | 0 6 files changed, 302 insertions(+) create mode 100755 R/drtable.R create mode 100755 R/fastdocall.R create mode 100755 R/func_wrapper.R create mode 100755 R/generate_output.R create mode 100755 R/log.R mode change 100644 => 100755 inst/WORDLIST diff --git a/R/drtable.R b/R/drtable.R new file mode 100755 index 00000000..f0b9a86f --- /dev/null +++ b/R/drtable.R @@ -0,0 +1,21 @@ +setClass( + "dVTableTree", + slots = c( + tbl = "VTableTree", + titles = "character", + footnotes = "character", + paper = "character", + width = "numeric" + ) +) + +setClass( + "dlisting", + slots = c( + lst = "listing_df", + titles = "character", + footnotes = "character", + paper = "character", + width = "numeric" + ) +) diff --git a/R/fastdocall.R b/R/fastdocall.R new file mode 100755 index 00000000..57a07fc2 --- /dev/null +++ b/R/fastdocall.R @@ -0,0 +1,52 @@ +#' Does do.call quicker, and avoids issues with debug mode within do.call +#' @description copied from ms showcase app +#' @param what either a function or a non-empty character string naming the function to be called. +#' @param args a list of arguments to the function call. The names attribute of args gives the argument names. +#' @param quote a logical value indicating whether to quote the arguments. +#' @param envir an environment within which to evaluate the call. This will be most useful if what is a character +#' string and the arguments are symbols or quoted expressions. +#' @export +fastDoCall <- + function(what, + args, + quote = FALSE, + envir = parent.frame()) { + if (quote) { + args <- lapply(args, enquote) + } + + if (is.null(names(args))) { + argn <- args + args <- list() + } else { + # Add all the named arguments + argn <- lapply(names(args)[names(args) != ""], as.name) + names(argn) <- names(args)[names(args) != ""] + # Add the unnamed arguments + argn <- c(argn, args[names(args) == ""]) + args <- args[names(args) != ""] + } + + if (is(what, "character")) { + if (is.character(what)) { + fn <- strsplit(what, "[:]{2,3}")[[1]] + what <- if (length(fn) == 1) { + get(fn[[1]], envir = envir, mode = "function") + } else { + get(fn[[2]], envir = asNamespace(fn[[1]]), mode = "function") + } + } + call <- as.call(c(list(what), argn)) + } else if (is(what, "function")) { + f_name <- deparse(substitute(what)) + call <- as.call(c(list(as.name(f_name)), argn)) + args[[f_name]] <- what + } else if (is(what, "name")) { + call <- as.call(c(list(what, argn))) + } + + eval(call, + envir = args, + enclos = envir + ) + } diff --git a/R/func_wrapper.R b/R/func_wrapper.R new file mode 100755 index 00000000..002786e5 --- /dev/null +++ b/R/func_wrapper.R @@ -0,0 +1,53 @@ +#' function wrapper to pass filtered data +#' @param func function name +#' @param datasets list of raw datasets +#' @param spec spec +#' @param verbose whether to show verbose information +#' @return a wrapped function using filtered adam +func_wrapper <- + function(func, datasets, spec, verbose = TRUE) { + suffix <- spec$suffix + function_args <- names(formals(func)) + datasets_filtered <- filters::apply_filter( + data = datasets, + id = suffix, + verbose = verbose + ) + + if ("datasets" %in% function_args) { + if ("spec" %in% function_args) { + return({ + function(...) { + fastDoCall(func, list(datasets_filtered, spec = spec, ...)) + } + }) + } else { + return({ + function(...) { + fastDoCall(func, list(datasets_filtered, ...)) + } + }) + } + } else { + # to keep compatibility with previous version + data_used <- + function_args[function_args %in% names(datasets)] + if ("spec" %in% function_args) { + return({ + function(...) { + fastDoCall(func, c( + datasets_filtered[data_used], + list(spec = spec), + list(...) + )) + } + }) + } else { + return({ + function(...) { + fastDoCall(func, c(datasets_filtered[data_used], list(...))) + } + }) + } + } + } diff --git a/R/generate_output.R b/R/generate_output.R new file mode 100755 index 00000000..1aafd0c0 --- /dev/null +++ b/R/generate_output.R @@ -0,0 +1,135 @@ +#' Generate output and apply filters, titles, and footnotes +#' +#' @param program program name +#' @param datasets list of datasets +#' @param spec spec +#' @param verbose_level Verbose level of messages be displayed. See details for further information. +#' @details +#' `verbose_level` is used to control how many messages are printed out. +#' By default, `2` will show all filter messages and show output generation message. +#' `1` will show output generation message only. +#' `0` will display no message. +#' @param ... arguments passed to program +#' +#' @author Liming Li (`Lil128`) +#' +#' @export +#' +#' @examples +#' filters::load_filters( +#' yaml_file = system.file("filters.yml", package = "autoslider.core"), +#' overwrite = TRUE +#' ) +#' +#' spec_file <- system.file("spec.yml", package = "autoslider.core") +#' spec <- spec_file %>% read_spec() +#' +#' data <- list( +#' adsl = eg_adsl, +#' adae = eg_adae +#' ) +#' generate_output("t_ae_slide", data, spec$t_ae_slide_SE) +#' +generate_output <- + function(program, + datasets, + spec, + verbose_level = 2, + ...) { + suffix <- spec$suffix + if (verbose_level > 0) { + cat_bullet( + sprintf( + "Running program `%s` with suffix '%s'.", + program, + suffix + ), + bullet = "pointer", + bullet_col = "green" + ) + } + func <- tryCatch( + { + func_wrapper( + func = match.fun(program), + datasets = datasets, + spec = spec, + verbose = verbose_level > 1 + ) + }, + error = function(e) { + info <- e$message + if (verbose_level > 0) { + cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red") + } + autoslider_error(info, spec = spec, step = "filter dataset") + } + ) + if (is(func, "autoslider_error")) { + return(func) + } + ret <- tryCatch( + { + func(...) + }, + error = function(e) { + info <- e$message + if (verbose_level > 0) { + cat_bullet(paste0("Error: ", info), bullet = "warning", bullet_col = "red") + } + autoslider_error(info, spec = spec, step = "user program") + } + ) + return(ret) + } + +#' Generate all outputs from a spec +#' +#' @param spec Specification list generated by `read_spec` +#' @param datasets A `list` of datasets +#' @param verbose_level Verbose level of messages be displayed. See details for further information. +#' @details +#' `verbose_level` is used to control how many messages are printed out. +#' By default, `2` will show all filter messages and show output generation message. +#' `1` will show output generation message only. +#' `0` will display no message. +#' +#' @author +#' - Thomas Neitmann (`neitmant`) +#' - Liming Li (`Lil128`) +#' +#' @export +#' +#' @examples +#' library(dplyr, warn.conflicts = FALSE) +#' data <- list( +#' adsl = eg_adsl, +#' adae = eg_adae +#' ) +#' filters::load_filters( +#' yaml_file = system.file("filters.yml", package = "autoslider.core"), +#' overwrite = TRUE +#' ) +#' +#' spec_file <- system.file("spec.yml", package = "autoslider.core") +#' spec_file %>% +#' read_spec() %>% +#' filter_spec(output %in% c("t_dm_slide_IT", "t_ae_slide_SE")) %>% +#' generate_outputs(datasets = data) +#' +generate_outputs <- function(spec, datasets, verbose_level = 2) { + lapply(spec, function(s) { + args <- c( + list( + program = s$program, + spec = s, + datasets = datasets, + verbose_level = verbose_level + ), + s$args # ... arguments passed onto the output-generating function + ) + output <- fastDoCall(generate_output, args) + attr(output, "spec") <- s + output + }) +} diff --git a/R/log.R b/R/log.R new file mode 100755 index 00000000..0abab2bb --- /dev/null +++ b/R/log.R @@ -0,0 +1,41 @@ +log_success_infomation <- function(success, failure) { + total_number <- success + failure + cat_bullet( + "Total number of success ", + success, + "/", + total_number, + bullet = "tick", + bullet_col = "green" + ) + if (failure > 0) { + cat_bullet( + "Total number of failures ", + failure, + "/", + total_number, + bullet = "cross", + bullet_col = "red" + ) + } +} + +log_number_of_matched_records <- function(original_spec, + filtered_spec, + condition) { + if (length(filtered_spec)) { + msg <- sprintf( + "%d/%d outputs matched the filter condition `%s`.", + length(filtered_spec), + length(original_spec), + deparse(condition) + ) + cat_bullet(msg, bullet = "tick", bullet_col = "green") + } else { + msg <- sprintf( + "No output matched the filter condition `%s`", + deparse(condition) + ) + cat_bullet(msg, bullet = "cross", bullet_col = "red") + } +} diff --git a/inst/WORDLIST b/inst/WORDLIST old mode 100644 new mode 100755