getPerformanceScore for binary endpoints enabled; issue #25 fixed

rpact-com · Mar 7, 2024 · 82be754 · 82be754
1 parent 53519ca
commit 82be754
Show file tree

Hide file tree

Showing 25 changed files with 8,855 additions and 8,650 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -48,3 +48,4 @@ testthat-problems\.rds
 ^inst/\.covrignore$
 ^README\.html$
 ^codecov\.yml$
+Rplots\.pdf
diff --git a/.gitignore b/.gitignore
@@ -31,3 +31,5 @@ testthat-problems.rds
 /src/*.gcno
 /src/*.gcov
 /README.html
+/tests/testthat/Rplots.pdf
+/tests/testthat/index.txt
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: rpact
 Title: Confirmatory Adaptive Clinical Trial Design and Analysis
-Version: 3.5.1
-Date: 2024-02-27
+Version: 3.5.2.9232
+Date: 2024-03-07
 Authors@R: c(
 	person(
 		given = "Gernot", 

diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,15 @@
 
+# rpact 3.5.2
+
+## New features
+
+* Extension of the function `getPerformanceScore()` for sample size recalculation rules to the setting of binary endpoints according to [Bokelmann et al. (2024)](https://doi.org/10.1186/s12874-024-02150-4)
+
+## Improvements, issues, and changes
+
+* Issue [#25](https://github.com/rpact-com/rpact/issues/25) fixed
+
+
 # rpact 3.5.1
 
 * The internal fields `.parameterNames` and `.parameterFormatFunctions` were removed from all rpact result objects in favor of a more efficient solution
@@ -40,7 +51,7 @@
 
 ## New features
 
-* The new function `getPerformanceScore()` calculates the conditional performance score, its sub-scores and components according to Herrmann et al. (2020) for a given simulation result from a two-stage design
+* The new function `getPerformanceScore()` calculates the conditional performance score, its sub-scores and components according to [Herrmann et al. (2020)](https://doi.org/10.1002/sim.8534) for a given simulation result from a two-stage design
 * `allocationRatioPlanned` for simulating multi-arm and enrichment designs can be a vector of length kMax, the number of stages 
 * `getObjectRCode()` (short: `rcmd()`): with the new arguments `pipeOperator` and `output` many new output variants can be specified, e.g., the native R pipe operator or the magrittr pipe operator can be used
 * Generic function `knitr::knit_print` for all result objects implemented and automatic code chunk option `results = 'asis'` activated

diff --git a/R/f_core_assertions.R b/R/f_core_assertions.R
@@ -13,9 +13,9 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7670 $
-## |  Last changed: $Date: 2024-02-26 15:46:14 +0100 (Mo, 26 Feb 2024) $
-## |  Last changed by: $Author: wassmer $
+## |  File version: $Revision: 7703 $
+## |  Last changed: $Date: 2024-03-07 13:38:48 +0100 (Do, 07 Mrz 2024) $
+## |  Last changed by: $Author: pahlke $
 ## |
 
 #' @include f_core_utilities.R
@@ -779,20 +779,74 @@ NULL
     }
 }
 
+.showParameterOutOfValidatedBoundsMessage <- function(
+    parameterValue, 
+    parameterName, ..., 
+    lowerBound = NA_real_, 
+    upperBound = NA_real_, 
+    spendingFunctionName = NA_character_,
+    closedLowerBound = TRUE,
+    closedUpperBound = TRUE) {
+
+    .assertIsSingleNumber(lowerBound, "lowerBound", naAllowed = TRUE)
+    .assertIsSingleNumber(upperBound, "upperBound", naAllowed = TRUE)
+    if (is.na(lowerBound) && is.na(upperBound)) {
+        stop(C_EXCEPTION_TYPE_MISSING_ARGUMENT, "'lowerBound' or 'upperBound' must be defined")
+    }
+
+    if (is.na(lowerBound)) {
+        lowerBound <- -Inf
+    }
+
+    if (is.na(upperBound)) {
+        upperBound <- Inf
+    }
+
+    if (closedLowerBound) {
+        bracketLowerBound <- "["
+        conditionLowerBound <- parameterValue < lowerBound
+    } else {
+        bracketLowerBound <- "("
+        conditionLowerBound <- parameterValue <= lowerBound
+    }
+    if (closedUpperBound) {
+        bracketUpperBound <- "]"
+        conditionUpperBound <- parameterValue > upperBound
+    } else {
+        bracketUpperBound <- ")"
+        conditionUpperBound <- parameterValue >= upperBound
+    }
+
+    if (conditionLowerBound || conditionUpperBound) {
+        if (!is.null(spendingFunctionName) && !is.na(spendingFunctionName)) {
+            spendingFunctionName <- paste0("for ", spendingFunctionName, " function ")
+        } else {
+            spendingFunctionName <- ""
+        }
+
+        type <- getOption("rpact.out.of.validated.bounds.message.type", "warning")
+        if (identical(type, "warning")) {
+            warning("The parameter ", sQuote(parameterName), " (", parameterValue, ") ", 
+                spendingFunctionName, "is out of validated bounds ", 
+                bracketLowerBound, lowerBound, "; ", upperBound, bracketUpperBound, call. = FALSE)
+        } 
+        else if (identical(type, "message")) {
+            message("Note that parameter ", sQuote(parameterName), " (", parameterValue, ") ", 
+                spendingFunctionName, "is out of validated bounds ", 
+                bracketLowerBound, lowerBound, "; ", upperBound, bracketUpperBound)
+        } 
+    }
+}
+
 .assertIsValidAlpha <- function(alpha) {
     .assertIsSingleNumber(alpha, "alpha")
-
-    if (alpha < 1e-06 || alpha >= 0.5) {
-        stop(
-            C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-            "'alpha' (", alpha, ") is out of bounds [1e-06; 0.5)"
-        )
-    }
+    .assertIsInOpenInterval(alpha, "alpha", lower = 0, upper = NULL)   
+    .showParameterOutOfValidatedBoundsMessage(alpha, "alpha", lowerBound = 1e-06, upperBound = 0.5, closedUpperBound = FALSE)
 }
 
 .assertIsValidKappa <- function(kappa) {
     .assertIsSingleNumber(kappa, "kappa")
-    .assertIsInOpenInterval(kappa, "kappa", lower = 0, upper = NULL)
+    .assertIsInOpenInterval(kappa, "kappa", lower = 0, upper = NULL)    
 }
 
 .assertIsValidLambda <- function(lambda, lambdaNumber = 0) {
@@ -861,13 +915,13 @@ NULL
 .assertIsValidBeta <- function(beta, alpha) {
     .assertIsSingleNumber(beta, "beta")
     .assertIsSingleNumber(alpha, "alpha")
-
+    .assertIsInOpenInterval(beta, "beta", lower = 0, upper = NULL)    
     if (beta < 1e-04 || beta >= 1 - alpha) {
-        stop(
+        warning(
             C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-            "'beta' (", beta, ") is out of bounds [1e-04; ", (1 - alpha), "); ",
-            "condition: 1e-05 <= alpha < 1 - beta <= 1 - 1e-04"
-        )
+            "'beta' (", beta, ") is out of validated bounds [1e-04; ", (1 - alpha), "); ",
+            "condition: 1e-05 <= alpha < 1 - beta <= 1 - 1e-04",
+            call. = FALSE)
     }
 }
 

diff --git a/R/f_design_group_sequential.R b/R/f_design_group_sequential.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7408 $
-## |  Last changed: $Date: 2023-11-09 10:36:19 +0100 (Do, 09 Nov 2023) $
+## |  File version: $Revision: 7703 $
+## |  Last changed: $Date: 2024-03-07 13:38:48 +0100 (Do, 07 Mrz 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -112,17 +112,16 @@ getGroupSequentialProbabilities <- function(decisionMatrix, informationRates) {
     if (design$typeOfDesign == C_TYPE_OF_DESIGN_WT) {
         .assertDesignParameterExists(design, "deltaWT", NA_real_)
         .assertIsSingleNumber(design$deltaWT, "deltaWT", naAllowed = FALSE)
-        .assertIsInClosedInterval(design$deltaWT, "deltaWT", lower = -0.5, upper = 1)
+        .showParameterOutOfValidatedBoundsMessage(design$deltaWT, "deltaWT", lowerBound = -0.5, upperBound = 1)
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_PT) {
         .assertDesignParameterExists(design, "deltaPT1", NA_real_)
         .assertIsSingleNumber(design$deltaPT1, "deltaPT1", naAllowed = FALSE)
-        .assertIsInClosedInterval(design$deltaPT1, "deltaPT1", lower = -0.5, upper = 1)
+        .showParameterOutOfValidatedBoundsMessage(design$deltaPT1, "deltaPT1", lowerBound = -0.5, upperBound = 1)
         .assertDesignParameterExists(design, "deltaPT0", NA_real_)
         .assertIsSingleNumber(design$deltaPT0, "deltaPT0", naAllowed = FALSE)
-        .assertIsInClosedInterval(design$deltaPT0, "deltaPT0", lower = -0.5, upper = 1)
+        .showParameterOutOfValidatedBoundsMessage(design$deltaPT0, "deltaPT0", lowerBound = -0.5, upperBound = 1)
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_WT_OPTIMUM) {
         .assertDesignParameterExists(design, "optimizationCriterion", C_OPTIMIZATION_CRITERION_DEFAULT)
-
         if (!.isOptimizationCriterion(design$optimizationCriterion)) {
             stop(
                 C_EXCEPTION_TYPE_ILLEGAL_ARGUMENT,
@@ -132,27 +131,19 @@ getGroupSequentialProbabilities <- function(decisionMatrix, informationRates) {
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_HP) {
         .assertDesignParameterExists(design, "constantBoundsHP", C_CONST_BOUND_HP_DEFAULT)
         .assertIsSingleNumber(design$constantBoundsHP, "constantBoundsHP")
-        .assertIsInClosedInterval(design$constantBoundsHP, "constantBoundsHP", lower = 2, upper = NULL)
+        .showParameterOutOfValidatedBoundsMessage(design$constantBoundsHP, "constantBoundsHP", lowerBound = 2)
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_AS_KD) {
         .assertDesignParameterExists(design, "gammaA", NA_real_)
         .assertIsSingleNumber(design$gammaA, "gammaA", naAllowed = FALSE)
-        if (design$gammaA < 0.4 || design$gammaA > 8) {
-            stop(
-                C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-                "parameter 'gammaA' (", design$gammaA, ") for Kim & DeMets alpha ",
-                "spending function is out of bounds [0.4; 8]"
-            )
-        }
+        .showParameterOutOfValidatedBoundsMessage(design$gammaA, "gammaA", 
+            lowerBound = 0.4, upperBound = 8,
+            spendingFunctionName = "Kim & DeMets alpha spending")
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_AS_HSD) {
         .assertDesignParameterExists(design, "gammaA", NA_real_)
         .assertIsSingleNumber(design$gammaA, "gammaA", naAllowed = FALSE)
-        if (design$gammaA < -10 || design$gammaA > 5) {
-            stop(
-                C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-                "Parameter 'gammaA' (", design$gammaA, ") for Hwang, Shih & DeCani ",
-                "alpha spending function is out of bounds [-10; 5]"
-            )
-        }
+        .showParameterOutOfValidatedBoundsMessage(design$gammaA, "gammaA", 
+            lowerBound = -10, upperBound = 5,
+            spendingFunctionName = "Hwang, Shih & DeCani alpha spending")
     } else if (design$typeOfDesign == C_TYPE_OF_DESIGN_AS_USER) {
         .validateUserAlphaSpending(design)
         design$.setParameterType("userAlphaSpending", C_PARAM_USER_DEFINED)
@@ -189,25 +180,17 @@ getGroupSequentialProbabilities <- function(decisionMatrix, informationRates) {
         if (design$typeBetaSpending == C_TYPE_OF_DESIGN_BS_KD) {
             .assertDesignParameterExists(design, "gammaB", NA_real_)
             .assertIsSingleNumber(design$gammaB, "gammaB", naAllowed = FALSE)
-            if (design$gammaB < 0.4 || design$gammaB > 8) {
-                stop(
-                    C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-                    "parameter 'gammaB' (", design$gammaB, ") for Kim & DeMets beta ",
-                    "spending function out of bounds [0.4; 8]"
-                )
-            }
+            .showParameterOutOfValidatedBoundsMessage(design$gammaB, "gammaB", 
+                lowerBound = 0.4, upperBound = 8,
+                spendingFunctionName = "Kim & DeMets beta spending", c(-0.4, 8))
         }
 
         if (design$typeBetaSpending == C_TYPE_OF_DESIGN_BS_HSD) {
             .assertDesignParameterExists(design, "gammaB", NA_real_)
             .assertIsSingleNumber(design$gammaB, "gammaB", naAllowed = FALSE)
-            if (design$gammaB < -10 || design$gammaB > 5) {
-                stop(
-                    C_EXCEPTION_TYPE_ARGUMENT_OUT_OF_BOUNDS,
-                    "parameter 'gammaB' (", design$gammaB, ") for Hwang, Shih & DeCani ",
-                    "beta spending out of bounds [-10; 5]"
-                )
-            }
+            .showParameterOutOfValidatedBoundsMessage(design$gammaB, "gammaB", 
+                lowerBound = -10, upperBound = 5,
+                spendingFunctionName = "Hwang, Shih & DeCani beta spending")
         }
 
         if (design$typeBetaSpending == C_TYPE_OF_DESIGN_BS_USER) {
@@ -1347,8 +1330,7 @@ getDesignInverseNormal <- function(...,
             if (!is.na(design$informationRates)) {
                 warning("Information rate", ifelse(length(design$informationRates) != 1, "s", ""), " ",
                     .arrayToString(design$informationRates, vectorLookAndFeelEnabled = TRUE),
-                    " will be ignored",
-                    call. = FALSE
+                    " will be ignored", call. = FALSE
                 )
             }
             design$informationRates <- 1

diff --git a/R/f_design_plan_plot.R b/R/f_design_plan_plot.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7645 $
-## |  Last changed: $Date: 2024-02-16 16:12:34 +0100 (Fr, 16 Feb 2024) $
+## |  File version: $Revision: 7701 $
+## |  Last changed: $Date: 2024-03-07 11:44:08 +0100 (Do, 07 Mrz 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -1034,7 +1034,7 @@
         timeTo <- max(designPlan$piecewiseSurvivalTime)
     }
     if (is.na(timeTo) || !is.numeric(timeTo) || is.infinite(timeTo)) {
-        # warning("Unable to determine upper bound of time values", call. = FALSE)
+        # unable to determine upper bound of time values
         timeTo <- 0
     }
 

diff --git a/R/f_simulation_enrichment_rates.R b/R/f_simulation_enrichment_rates.R
@@ -13,9 +13,9 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7383 $
-## |  Last changed: $Date: 2023-11-02 15:18:21 +0100 (Do, 02 Nov 2023) $
-## |  Last changed by: $Author: pahlke $
+## |  File version: $Revision: 7679 $
+## |  Last changed: $Date: 2024-03-04 15:00:35 +0100 (Mo, 04 Mrz 2024) $
+## |  Last changed by: $Author: wassmer $
 ## |
 
 #' @include f_simulation_enrichment.R
@@ -707,10 +707,13 @@ NULL
 
             thetaStandardized <- (2 * directionUpper - 1) * thetaStandardized
 
-            thetaStandardized <- min(thetaStandardized, na.rm = TRUE)
-
-            conditionalPowerPerStage[k] <- 1 - stats::pnorm(conditionalCriticalValue[k] -
-                thetaStandardized * sqrt(plannedSubjects[k + 1] - plannedSubjects[k]))
+            if (any(!is.na(thetaStandardized))){
+                thetaStandardized <- min(thetaStandardized, na.rm = TRUE)
+                conditionalPowerPerStage[k] <- 1 - stats::pnorm(conditionalCriticalValue[k] -
+                    thetaStandardized * sqrt(plannedSubjects[k + 1] - plannedSubjects[k]))
+            } else {
+                conditionalPowerPerStage[k] <- 0
+            }
         }
     }
     return(list(

diff --git a/R/f_simulation_performance_score.R b/R/f_simulation_performance_score.R
@@ -13,8 +13,8 @@
 ## |
 ## |  Contact us for information about our services: info@rpact.com
 ## |
-## |  File version: $Revision: 7644 $
-## |  Last changed: $Date: 2024-02-16 10:36:28 +0100 (Fr, 16 Feb 2024) $
+## |  File version: $Revision: 7688 $
+## |  Last changed: $Date: 2024-03-05 14:56:47 +0100 (Tue, 05 Mar 2024) $
 ## |  Last changed by: $Author: pahlke $
 ## |
 
@@ -23,8 +23,10 @@
 #' Get Performance Score
 #'
 #' @description
-#' Calculates the conditional performance score, its sub-scores and components according to
-#' Herrmann et al. (2020) for a given simulation result from a two-stage design.
+#' Calculates the conditional performance score, its sub-scores and components according to 
+#' [Herrmann et al. (2020)](https://doi.org/10.1002/sim.8534) and 
+#' [Bokelmann et al. (2024)](https://doi.org/10.1186/s12874-024-02150-4) for a given 
+#' simulation result from a two-stage design with continuous or binary endpoint.
 #' Larger (sub-)score and component values refer to a better performance.
 #'
 #' @param simulationResult A simulation result.
@@ -37,7 +39,8 @@
 #' The term conditional refers to an evaluation perspective where the interim results
 #' suggest a trial continuation with a second stage.
 #' The score can take values between 0 and 1. More details on the performance score
-#' can be found in Herrmann et al. (2020).
+#' can be found in [Herrmann et al. (2020)](https://doi.org/10.1002/sim.8534) and 
+#' [Bokelmann et al. (2024)](https://doi.org/10.1186/s12874-024-02150-4).
 #' 
 #' @template examples_get_performance_score
 #'
@@ -50,10 +53,10 @@ getPerformanceScore <- function(simulationResult) {
 
     design <- simulationResult$.design
 
-    if (!inherits(simulationResult, "SimulationResultsMeans")) { 
+    if (!inherits(simulationResult, "SimulationResultsMeans") && !inherits(simulationResult, "SimulationResultsRates")) { 
         stop(
             C_EXCEPTION_TYPE_ILLEGAL_ARGUMENT,
-            "performance score so far implemented only for single comparisons with continuous endpoints"
+            "performance score so far implemented only for single comparisons with continuous and binary endpoints"
         )
     }
 

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-02-21" />
+<meta name="date" content="2024-03-07" />
 
 <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-02-21</h4>
+<h4 class="date">2024-03-07</h4>