Function pull() added

rpact-com · Mar 28, 2024 · e2294a7 · e2294a7
1 parent f09af59
commit e2294a7
Show file tree

Hide file tree

Showing 7 changed files with 127 additions and 30 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: rpact
 Title: Confirmatory Adaptive Clinical Trial Design and Analysis
-Version: 4.0.0.9236
-Date: 2024-03-26
+Version: 4.0.0.9238
+Date: 2024-03-28
 Authors@R: c(
 	person(
 		given = "Gernot", 

diff --git a/NAMESPACE b/NAMESPACE
@@ -38,6 +38,7 @@ S3method(print,ParameterSet)
 S3method(print,SimulationResults)
 S3method(print,SummaryFactory)
 S3method(print,TrialDesignCharacteristics)
+S3method(pull,ParameterSet)
 S3method(summary,AnalysisResults)
 S3method(summary,Dataset)
 S3method(summary,ParameterSet)
@@ -119,6 +120,7 @@ export(mvstud)
 export(plotTypes)
 export(ppwexp)
 export(printCitation)
+export(pull)
 export(qpwexp)
 export(rcmd)
 export(readDataset)

diff --git a/R/class_analysis_dataset.R b/R/class_analysis_dataset.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7742 $
-## |  Last changed: $Date: 2024-03-22 13:46:29 +0100 (Fr, 22 Mrz 2024) $
+## |  File version: $Revision: 7763 $
+## |  Last changed: $Date: 2024-03-28 14:35:29 +0100 (Do, 28 Mrz 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -463,7 +463,9 @@ writeDatasets <- function(datasets, file, ..., append = FALSE, quote = TRUE, sep
             }
         }
 
-        return(.getEnrichmentDatasetFromArgs(...))
+        dataset <- .getEnrichmentDatasetFromArgs(...)
+        dataset$.design <- design
+        return(dataset)
     }
 
     exampleType <- args[["example"]]
@@ -881,12 +883,13 @@ getDataSet <- function(..., floatingPointNumbersEnabled = FALSE) {
     subsetNumbers <- as.integer(subsetNumbers)
     gMax <- max(subsetNumbers) + 1
     validSubsetNames <- .createSubsetsByGMax(gMax, stratifiedInput = stratifiedInput, all = FALSE)
-    for (subsetName in subsetNames) {
-        if (subsetName == "") {
+    for (i in 1:length(subsetNames)) {
+        subsetName <- subsetNames[i]
+        if (subsetName == "" && !inherits(args[[i]], "TrialDesign")) {
             stop(C_EXCEPTION_TYPE_ILLEGAL_ARGUMENT, "all subsets must be named")
         }
 
-        if (!(subsetName %in% validSubsetNames)) {
+        if (subsetName != "" && !(subsetName %in% validSubsetNames)) {
             suffix <- ifelse(stratifiedInput, " (stratified analysis)", " (non-stratified analysis)")
             if (length(validSubsetNames) < 10) {
                 stop(
@@ -903,7 +906,8 @@ getDataSet <- function(..., floatingPointNumbersEnabled = FALSE) {
             }
         }
     }
-
+
+    subsetNames <- subsetNames[subsetNames != ""]
     subsets <- NULL
     subsetType <- NA_character_
     emptySubsetNames <- validSubsetNames[!(validSubsetNames %in% subsetNames)]

diff --git a/R/class_core_parameter_set.R b/R/class_core_parameter_set.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7750 $
-## |  Last changed: $Date: 2024-03-26 15:44:44 +0100 (Di, 26 Mrz 2024) $
+## |  File version: $Revision: 7763 $
+## |  Last changed: $Date: 2024-03-28 14:35:29 +0100 (Do, 28 Mrz 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -1631,14 +1631,62 @@ print.ParameterSet <- function(x, ..., markdown = NA) {
 
     if (markdown) {
         x$.catMarkdownText()
-        cat("\n\n")
     } else {
         x$show()
     }
+
+    if (isTRUE(markdown)) {
+        attr(x, "markdown") <- TRUE
+    }
 
     return(invisible(x))
 }
 
+#' @export 
+pull <- function(x, var) UseMethod("pull")
+
+#'
+#' Extract a single parameter
+#' 
+#' Pull a parameter from a parameter set.
+#' 
+#' @param  var A variable specified as: 
+#'  - a literal variable name 
+#'  - a positive integer, giving the position counting from the left 
+#'  - a negative integer, giving the position counting from the right. 
+#' The default returns the last column (on the assumption that's the column you've created most recently). 
+#' This argument is taken by expression and supports quasiquotation (you can unquote column names and column locations).
+#' 
+#' @export 
+#' 
+pull.ParameterSet <- function(x, var = -1) {
+    fCall <- match.call(expand.dots = FALSE)
+    varName <- deparse(fCall$var)
+    if (!exists(varName) || (!is.character(var) && !is.integer(var))) {
+        var <- gsub('"', "", varName)
+        var <- gsub("'", "", var)
+    }
+
+    if (is.character(var)) {
+        if (!(var %in% names(x))) {
+            stop(C_EXCEPTION_TYPE_ILLEGAL_ARGUMENT, "variable ", sQuote(var), " does not exist")
+        }
+
+        return(x[[var]])
+    }
+
+    .assertIsSingleInteger(x, "x", validateType = FALSE)
+    .assertIsInClosedInterval(x, "x", lower = -length(x), upper = length(x))
+    if (var == 0) {
+        stop(C_EXCEPTION_TYPE_ILLEGAL_ARGUMENT, "'x' (", x, ") must != 0")
+    }
+    x <- addTrace(x, "pull", var)
+    if (var < 0) {
+        var <- length(x) + 1 - var
+    }
+    return(x[[var]])
+}
+
 #'
 #' @title
 #' Parameter Set Plotting

diff --git a/R/class_summary.R b/R/class_summary.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7742 $
-## |  Last changed: $Date: 2024-03-22 13:46:29 +0100 (Fr, 22 Mrz 2024) $
+## |  File version: $Revision: 7763 $
+## |  Last changed: $Date: 2024-03-28 14:35:29 +0100 (Do, 28 Mrz 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -123,6 +123,11 @@ knit_print.SummaryFactory <- function(x, ...) {
             paste0(utils::capture.output(x$object$.catMarkdownText()), collapse = "\n")
         )
     }
+
+    if (isTRUE(x[["markdown"]])) {
+        sep <- "\n-----\n\n"
+        result <- paste0(sep, result)
+    }
 
     return(knitr::asis_output(result))
 }
@@ -152,9 +157,10 @@ print.SummaryFactory <- function(x, ...,
         markdown <- .isMarkdownEnabled()
     }
 
-    if (markdown) {
+    if (markdown || isTRUE(x[["markdown"]])) {
         result <- paste0(utils::capture.output(x$.catMarkdownText()), collapse = "\n")
-        cat(result, "\n")
+        cat(sep)
+        cat(trimws(result), "\n")
         return(invisible())
     }
 
@@ -183,11 +189,13 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
         intervalFormat = NULL,
         justify = NULL,
         output = NULL,
-        initialize = function(..., object = NULL, intervalFormat = "[%s; %s]", output = "all") {
+        markdown = NULL,
+        initialize = function(..., object = NULL, intervalFormat = "[%s; %s]", output = "all", markdown = FALSE) {
             super$initialize(...)
             self$object <- object
             self$intervalFormat <- intervalFormat
             self$output <- output
+            self$markdown <- markdown
             self$summaryItems <- list()
             self$justify <- getOption("rpact.summary.justify", "right")
         },
@@ -2370,29 +2378,41 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
 
 .createSummary <- function(object, digits = NA_integer_, output = c("all", "title", "overview", "body")) {
     output <- match.arg(output)
+
+    markdown <- attr(object, "markdown")
+    if (is.null(markdown) || length(markdown) == 0 || !is.logical(markdown)) {
+        markdown <- FALSE
+    }
+
     if (inherits(object, "TrialDesignCharacteristics")) {
-        return(.createSummaryDesignPlan(object, digits = digits, output = output, showStageLevels = TRUE))
+        return(.createSummaryDesignPlan(object, digits = digits, output = output, 
+                showStageLevels = TRUE, markdown = markdown))
     }
 
     if (.isTrialDesign(object) || .isTrialDesignPlan(object) || inherits(object, "SimulationResults")) {
-        return(.createSummaryDesignPlan(object, digits = digits, output = output, showStageLevels = !.isTrialDesignPlan(object)))
+        return(.createSummaryDesignPlan(object, digits = digits, output = output, 
+                showStageLevels = !.isTrialDesignPlan(object), markdown = markdown))
     }
 
     if (inherits(object, "AnalysisResults")) {
-        return(.createSummaryAnalysisResults(object, digits = digits, output = output))
+        return(.createSummaryAnalysisResults(object, digits = digits, output = output, markdown = markdown))
     }
 
     if (inherits(object, "PerformanceScore")) {
-        return(.createSummaryPerformanceScore(object, digits = digits, output = output))
+        return(.createSummaryPerformanceScore(object, digits = digits, output = output, markdown = markdown))
     }
 
     stop(C_EXCEPTION_TYPE_RUNTIME_ISSUE, "function 'summary' not implemented yet for class ", .getClassName(object))
 }
 
-.createSummaryPerformanceScore <- function(object, digits = NA_integer_, output = c("all", "title", "overview", "body")) {
+.createSummaryPerformanceScore <- function(object, ..., 
+        digits = NA_integer_, 
+        output = c("all", "title", "overview", "body"), 
+        markdown = FALSE) {
     .createSummaryDesignPlan(object$.simulationResults,
         digits = digits, output = output,
-        showStageLevels = TRUE, performanceScore = object
+        showStageLevels = TRUE, performanceScore = object,
+        markdown = markdown
     )
 }
 
@@ -2420,7 +2440,8 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
 #'
 #' @noRd
 #'
-.createSummaryAnalysisResults <- function(object, digits = NA_integer_, output = c("all", "title", "overview", "body")) {
+.createSummaryAnalysisResults <- function(object, ..., digits = NA_integer_, 
+        output = c("all", "title", "overview", "body"), markdown = FALSE) {
     output <- match.arg(output)
     if (!inherits(object, "AnalysisResults")) {
         stop(
@@ -2457,7 +2478,8 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
         }
     }
 
-    summaryFactory <- SummaryFactory$new(object = object, intervalFormat = intervalFormat, output = output)
+    summaryFactory <- SummaryFactory$new(object = object, 
+        intervalFormat = intervalFormat, output = output, markdown = markdown)
 
     .addDesignInformationToSummary(design, object, summaryFactory, output = output)
 
@@ -2957,7 +2979,7 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
 #'
 .createSummaryDesignPlan <- function(object, digits = NA_integer_,
         output = c("all", "title", "overview", "body"), showStageLevels = FALSE,
-        performanceScore = NULL) {
+        performanceScore = NULL, markdown = FALSE) {
     output <- match.arg(output)
     designPlan <- NULL
     if (.isTrialDesignPlan(object) || inherits(object, "SimulationResults")) {
@@ -2987,7 +3009,7 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
     intervalFormat <- getOption("rpact.summary.intervalFormat", "[%s; %s]")
     .assertIsValidSummaryIntervalFormat(intervalFormat)
 
-    summaryFactory <- SummaryFactory$new(object = object, intervalFormat = intervalFormat, output = output)
+    summaryFactory <- SummaryFactory$new(object = object, intervalFormat = intervalFormat, output = output, markdown = markdown)
 
     if (output %in% c("all", "title", "overview")) {
         .addDesignInformationToSummary(design, designPlan, summaryFactory, output = output)
@@ -3155,7 +3177,7 @@ SummaryFactory <- R6::R6Class("SummaryFactory",
         }
 
         # simulation multi-arm #5: earlyStop per mu_max
-        if (outputSize %in% c("medium", "large")) {
+        if (design$kMax > 1 && outputSize %in% c("medium", "large")) {
             summaryFactory$addParameter(designPlan,
                 parameterName = "earlyStop",
                 parameterCaption = "Overall exit probability", # (under H1)

diff --git a/inst/doc/rpact_getting_started.html b/inst/doc/rpact_getting_started.html
@@ -12,7 +12,7 @@
 
 <meta name="author" content="Friedrich Pahlke and Gernot Wassmer" />
 
-<meta name="date" content="2024-03-26" />
+<meta name="date" content="2024-03-28" />
 
 <title>Getting started with rpact</title>
 
@@ -239,7 +239,7 @@
 
 <h1 class="title toc-ignore">Getting started with rpact</h1>
 <h4 class="author">Friedrich Pahlke and Gernot Wassmer</h4>
-<h4 class="date">2024-03-26</h4>
+<h4 class="date">2024-03-28</h4>
 
 
 

diff --git a/man/pull.ParameterSet.Rd b/man/pull.ParameterSet.Rd