
Group sequential design using weighted log-rank test under non-proportional hazards
Source:R/gs_design_wlr.R
gs_design_wlr.Rd
Group sequential design using weighted log-rank test under non-proportional hazards
Usage
gs_design_wlr(
enroll_rate = define_enroll_rate(duration = c(2, 2, 10), rate = c(3, 6, 9)),
fail_rate = tibble(stratum = "All", duration = c(3, 100), fail_rate = log(2)/c(9, 18),
hr = c(0.9, 0.6), dropout_rate = rep(0.001, 2)),
weight = wlr_weight_fh,
approx = "asymptotic",
alpha = 0.025,
beta = 0.1,
ratio = 1,
info_frac = NULL,
info_scale = c("h0_h1_info", "h0_info", "h1_info"),
analysis_time = 36,
binding = FALSE,
upper = gs_spending_bound,
upar = list(sf = gsDesign::sfLDOF, total_spend = alpha),
lower = gs_spending_bound,
lpar = list(sf = gsDesign::sfLDOF, total_spend = beta),
test_upper = TRUE,
test_lower = TRUE,
h1_spending = TRUE,
r = 18,
tol = 1e-06,
interval = c(0.01, 1000)
)
Arguments
- enroll_rate
Enrollment rates defined by
define_enroll_rate()
.- fail_rate
Failure and dropout rates defined by
define_fail_rate()
.- weight
Weight of weighted log rank test:
"1"
= unweighted."n"
= Gehan-Breslow."sqrtN"
= Tarone-Ware."FH_p[a]_q[b]"
= Fleming-Harrington with p=a and q=b.
- approx
Approximate estimation method for Z statistics.
"event_driven"
= only work under proportional hazard model with log rank test."asymptotic"
.
- alpha
One-sided Type I error.
- beta
Type II error.
- ratio
Experimental:Control randomization ratio.
- info_frac
Targeted information fraction for analyses. See details.
- info_scale
Information scale for calculation. Options are:
"h0_h1_info"
(default): variance under both null and alternative hypotheses is used."h0_info"
: variance under null hypothesis is used."h1_info"
: variance under alternative hypothesis is used.
- analysis_time
Targeted calendar timing of analyses. See details.
- binding
Indicator of whether futility bound is binding; default of
FALSE
is recommended.- upper
Function to compute upper bound.
gs_spending_bound()
: alpha-spending efficacy bounds.gs_b()
: fixed efficacy bounds.
- upar
Parameters passed to
upper
.If
upper = gs_b
, thenupar
is a numerical vector specifying the fixed efficacy bounds per analysis.If
upper = gs_spending_bound
, thenupar
is a list includingsf
for the spending function family.total_spend
for total alpha spend.param
for the parameter of the spending function.timing
specifies spending time if different from information-based spending; see details.
- lower
Function to compute lower bound, which can be set up similarly as
upper
. See this vignette.- lpar
Parameters passed to
lower
, which can be set up similarly asupar.
- test_upper
Indicator of which analyses should include an upper (efficacy) bound; single value of
TRUE
(default) indicates all analyses; otherwise, a logical vector of the same length asinfo
should indicate which analyses will have an efficacy bound.- test_lower
Indicator of which analyses should include an lower bound; single value of
TRUE
(default) indicates all analyses; single valueFALSE
indicated no lower bound; otherwise, a logical vector of the same length asinfo
should indicate which analyses will have a lower bound.- h1_spending
Indicator that lower bound to be set by spending under alternate hypothesis (input
fail_rate
) if spending is used for lower bound. If this isFALSE
, then the lower bound spending is under the null hypothesis. This is for two-sided symmetric or asymmetric testing under the null hypothesis; See this vignette.- r
Integer value controlling grid for numerical integration as in Jennison and Turnbull (2000); default is 18, range is 1 to 80. Larger values provide larger number of grid points and greater accuracy. Normally,
r
will not be changed by the user.- tol
Tolerance parameter for boundary convergence (on Z-scale); normally not changed by the user.
- interval
An interval presumed to include the times at which expected event count is equal to targeted event. Normally, this can be ignored by the user as it is set to
c(.01, 1000)
.
Examples
library(dplyr)
library(mvtnorm)
library(gsDesign)
library(gsDesign2)
# set enrollment rates
enroll_rate <- define_enroll_rate(duration = 12, rate = 1)
# set failure rates
fail_rate <- define_fail_rate(
duration = c(4, 100),
fail_rate = log(2) / 15, # median survival 15 month
hr = c(1, .6),
dropout_rate = 0.001
)
# Example 1 ----
# Information fraction driven design
gs_design_wlr(
enroll_rate = enroll_rate,
fail_rate = fail_rate,
ratio = 1,
alpha = 0.025, beta = 0.2,
weight = function(x, arm0, arm1) {
wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
},
upper = gs_spending_bound,
upar = list(sf = gsDesign::sfLDOF, total_spend = 0.025),
lower = gs_spending_bound,
lpar = list(sf = gsDesign::sfLDOF, total_spend = 0.2),
analysis_time = 36,
info_frac = c(0.6, 1)
)
#> $input
#> $input$enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 1
#>
#> $input$fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $input$weight
#> function (x, arm0, arm1)
#> {
#> wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
#> }
#> <environment: 0x55e552ab9488>
#>
#> $input$approx
#> [1] "asymptotic"
#>
#> $input$alpha
#> [1] 0.025
#>
#> $input$beta
#> [1] 0.2
#>
#> $input$ratio
#> [1] 1
#>
#> $input$info_frac
#> [1] 0.6 1.0
#>
#> $input$analysis_time
#> [1] 36
#>
#> $input$upper
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$upar
#> $input$upar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$upar$total_spend
#> [1] 0.025
#>
#>
#> $input$lower
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$lpar
#> $input$lpar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$lpar$total_spend
#> [1] 0.2
#>
#>
#> $input$test_upper
#> [1] TRUE
#>
#> $input$test_lower
#> [1] TRUE
#>
#> $input$h1_spending
#> [1] TRUE
#>
#> $input$binding
#> [1] FALSE
#>
#> $input$info_scale
#> [1] "h0_h1_info"
#>
#> $input$r
#> [1] 18
#>
#> $input$tol
#> [1] 1e-06
#>
#>
#> $enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 24.1
#>
#> $fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $bounds
#> # A tibble: 4 × 7
#> analysis bound probability probability0 z `~hr at bound` `nominal p`
#> <int> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 upper 0.0884 0.00381 2.67 0.645 0.00381
#> 2 1 lower 0.101 0.504 0.0102 0.998 0.496
#> 3 2 upper 0.800 0.0249 1.98 0.751 0.0238
#> 4 2 lower 0.200 0.974 1.96 0.754 0.0253
#>
#> $analysis
#> # A tibble: 2 × 10
#> analysis time n event ahr theta info info0 info_frac info_frac0
#> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 25.2 289. 148. 0.661 0.414 9.63 9.88 0.612 0.600
#> 2 2 36 289. 192. 0.639 0.732 15.7 16.5 1 1
#>
#> attr(,"class")
#> [1] "non_binding" "wlr" "gs_design" "list"
#> attr(,"uninteger_is_from")
#> [1] "gs_design_wlr"
# Example 2 ----
# Calendar time driven design
gs_design_wlr(
enroll_rate = enroll_rate,
fail_rate = fail_rate,
ratio = 1,
alpha = 0.025, beta = 0.2,
weight = function(x, arm0, arm1) {
wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
},
upper = gs_spending_bound,
upar = list(sf = gsDesign::sfLDOF, total_spend = 0.025),
lower = gs_spending_bound,
lpar = list(sf = gsDesign::sfLDOF, total_spend = 0.2),
analysis_time = c(24, 36),
info_frac = NULL
)
#> $input
#> $input$enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 1
#>
#> $input$fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $input$weight
#> function (x, arm0, arm1)
#> {
#> wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
#> }
#> <environment: 0x55e552ab9488>
#>
#> $input$approx
#> [1] "asymptotic"
#>
#> $input$alpha
#> [1] 0.025
#>
#> $input$beta
#> [1] 0.2
#>
#> $input$ratio
#> [1] 1
#>
#> $input$info_frac
#> [1] 0.5525079 1.0000000
#>
#> $input$analysis_time
#> [1] 24 36
#>
#> $input$upper
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$upar
#> $input$upar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$upar$total_spend
#> [1] 0.025
#>
#>
#> $input$lower
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$lpar
#> $input$lpar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$lpar$total_spend
#> [1] 0.2
#>
#>
#> $input$test_upper
#> [1] TRUE
#>
#> $input$test_lower
#> [1] TRUE
#>
#> $input$h1_spending
#> [1] TRUE
#>
#> $input$binding
#> [1] FALSE
#>
#> $input$info_scale
#> [1] "h0_h1_info"
#>
#> $input$r
#> [1] 18
#>
#> $input$tol
#> [1] 1e-06
#>
#>
#> $enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 23.2
#>
#> $fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $bounds
#> # A tibble: 4 × 7
#> analysis bound probability probability0 z `~hr at bound` `nominal p`
#> <int> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 upper 0.299 0.00257 2.80 0.620 0.00257
#> 2 1 lower 0.0866 0.812 0.886 0.860 0.188
#> 3 2 upper 0.800 0.0223 1.97 0.748 0.0242
#> 4 2 lower 0.198 0.975 1.92 0.753 0.0273
#>
#> $analysis
#> # A tibble: 2 × 10
#> analysis time n event ahr theta info info0 info_frac info_frac0
#> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 24 278. 137. 0.666 0.765 8.56 8.76 0.565 0.553
#> 2 2 36 278. 184. 0.639 0.732 15.1 15.9 1 1
#>
#> attr(,"class")
#> [1] "non_binding" "wlr" "gs_design" "list"
#> attr(,"uninteger_is_from")
#> [1] "gs_design_wlr"
# Example 3 ----
# Both calendar time and information fraction driven design
gs_design_wlr(
enroll_rate = enroll_rate,
fail_rate = fail_rate,
ratio = 1,
alpha = 0.025, beta = 0.2,
weight = function(x, arm0, arm1) {
wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
},
upper = gs_spending_bound,
upar = list(sf = gsDesign::sfLDOF, total_spend = 0.025),
lower = gs_spending_bound,
lpar = list(sf = gsDesign::sfLDOF, total_spend = 0.2),
analysis_time = c(24, 36),
info_frac = c(0.6, 1)
)
#> $input
#> $input$enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 1
#>
#> $input$fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $input$weight
#> function (x, arm0, arm1)
#> {
#> wlr_weight_fh(x, arm0, arm1, rho = 0, gamma = 0.5)
#> }
#> <environment: 0x55e552ab9488>
#>
#> $input$approx
#> [1] "asymptotic"
#>
#> $input$alpha
#> [1] 0.025
#>
#> $input$beta
#> [1] 0.2
#>
#> $input$ratio
#> [1] 1
#>
#> $input$info_frac
#> [1] 0.6 1.0
#>
#> $input$analysis_time
#> [1] 24 36
#>
#> $input$upper
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$upar
#> $input$upar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$upar$total_spend
#> [1] 0.025
#>
#>
#> $input$lower
#> function (k = 1, par = list(sf = gsDesign::sfLDOF, total_spend = 0.025,
#> param = NULL, timing = NULL, max_info = NULL), hgm1 = NULL,
#> theta = 0.1, info = 1:3, efficacy = TRUE, test_bound = TRUE,
#> r = 18, tol = 1e-06)
#> {
#> if (length(test_bound) == 1 && k > 1) {
#> test_bound <- rep(test_bound, k)
#> }
#> if (!is.null(par$timing)) {
#> timing <- par$timing
#> }
#> else {
#> if (is.null(par$max_info)) {
#> timing <- info/max(info)
#> }
#> else {
#> timing <- info/par$max_info
#> }
#> }
#> if (!is.function(sf <- par$sf))
#> sf <- tryCatch(match.fun(sf), error = function(e) {
#> getExportedValue("gsDesign", sf)
#> })
#> spend <- sf(alpha = par$total_spend, t = timing, param = par$param)$spend
#> old_spend <- 0
#> for (i in 1:k) {
#> if (test_bound[i]) {
#> xx <- spend[i] - old_spend
#> old_spend <- spend[i]
#> spend[i] <- xx
#> }
#> else {
#> spend[i] <- 0
#> }
#> }
#> spend <- spend[k]
#> if (!efficacy) {
#> if (spend <= 0) {
#> return(-Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> a <- qnorm(spend) + sqrt(info[k]) * theta[k]
#> if (k == 1) {
#> return(a)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> adelta <- 1
#> j <- 0
#> while (abs(adelta) > tol) {
#> hg <- hupdate(theta = theta[k], info = info[k], a = -Inf,
#> b = a, thetam1 = theta[k - 1], im1 = info[k -
#> 1], gm1 = hgm1, r = r)
#> i <- length(hg$h)
#> pik <- sum(hg$h)
#> adelta <- spend - pik
#> dplo <- hg$h[i]/hg$w[i]
#> if (adelta > dplo) {
#> adelta <- 1
#> }
#> else if (adelta < -dplo) {
#> adelta <- -1
#> }
#> else {
#> adelta <- adelta/dplo
#> }
#> a <- a + adelta
#> if (a > extreme_high) {
#> a <- extreme_high
#> }
#> else if (a < extreme_low) {
#> a <- extreme_low
#> }
#> if (abs(adelta) < tol) {
#> return(a)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> else {
#> if (spend <= 0) {
#> return(Inf)
#> }
#> if (length(theta) == 1)
#> theta <- rep(theta, length(info))
#> b <- qnorm(spend, lower.tail = FALSE)
#> if (k == 1) {
#> return(b)
#> }
#> mu <- theta[k] * sqrt(info[k])
#> extreme_low <- mu - 3 - 4 * log(r)
#> extreme_high <- mu + 3 + 4 * log(r)
#> bdelta <- 1
#> j <- 1
#> while (abs(bdelta) > tol) {
#> hg <- hupdate(theta = 0, info = info[k], a = b, b = Inf,
#> thetam1 = 0, im1 = info[k - 1], gm1 = hgm1, r = r)
#> pik <- sum(hg$h)
#> bdelta <- spend - pik
#> dpikdb <- hg$h[1]/hg$w[1]
#> if (bdelta > dpikdb) {
#> bdelta <- 1
#> }
#> else if (bdelta < -dpikdb) {
#> bdelta <- -1
#> }
#> else {
#> bdelta <- bdelta/dpikdb
#> }
#> b <- b - bdelta
#> if (b > extreme_high) {
#> b <- extreme_high
#> }
#> else if (b < extreme_low) {
#> b <- extreme_low
#> }
#> if (abs(bdelta) < tol) {
#> return(b)
#> }
#> j <- j + 1
#> if (j > 20) {
#> stop(paste("gs_spending_bound(): bound_update did not converge for lower bound calculation, analysis",
#> k, " !"))
#> }
#> }
#> }
#> }
#> <bytecode: 0x55e5506c1358>
#> <environment: namespace:gsDesign2>
#>
#> $input$lpar
#> $input$lpar$sf
#> function (alpha, t, param = NULL)
#> {
#> checkScalar(alpha, "numeric", c(0, Inf), c(FALSE, FALSE))
#> checkVector(t, "numeric", c(0, Inf), c(TRUE, FALSE))
#> if (is.null(param) || param < 0.005 || param > 20)
#> param <- 1
#> checkScalar(param, "numeric", c(0.005, 20), c(TRUE, TRUE))
#> t[t > 1] <- 1
#> if (param == 1) {
#> rho <- 1
#> txt <- "Lan-DeMets O'Brien-Fleming approximation"
#> parname <- "none"
#> }
#> else {
#> rho <- param
#> txt <- "Generalized Lan-DeMets O'Brien-Fleming"
#> parname <- "rho"
#> }
#> z <- -qnorm(alpha/2)
#> x <- list(name = txt, param = param, parname = parname, sf = sfLDOF,
#> spend = 2 * (1 - pnorm(z/t^(rho/2))), bound = NULL, prob = NULL)
#> class(x) <- "spendfn"
#> x
#> }
#> <bytecode: 0x55e549003bc0>
#> <environment: namespace:gsDesign>
#>
#> $input$lpar$total_spend
#> [1] 0.2
#>
#>
#> $input$test_upper
#> [1] TRUE
#>
#> $input$test_lower
#> [1] TRUE
#>
#> $input$h1_spending
#> [1] TRUE
#>
#> $input$binding
#> [1] FALSE
#>
#> $input$info_scale
#> [1] "h0_h1_info"
#>
#> $input$r
#> [1] 18
#>
#> $input$tol
#> [1] 1e-06
#>
#>
#> $enroll_rate
#> # A tibble: 1 × 3
#> stratum duration rate
#> <chr> <dbl> <dbl>
#> 1 All 12 24.1
#>
#> $fail_rate
#> # A tibble: 2 × 5
#> stratum duration fail_rate dropout_rate hr
#> <chr> <dbl> <dbl> <dbl> <dbl>
#> 1 All 4 0.0462 0.001 1
#> 2 All 100 0.0462 0.001 0.6
#>
#> $bounds
#> # A tibble: 4 × 7
#> analysis bound probability probability0 z `~hr at bound` `nominal p`
#> <int> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 upper 0.0884 0.00381 2.67 0.645 0.00381
#> 2 1 lower 0.101 0.504 0.0102 0.998 0.496
#> 3 2 upper 0.800 0.0249 1.98 0.751 0.0238
#> 4 2 lower 0.200 0.974 1.96 0.754 0.0253
#>
#> $analysis
#> # A tibble: 2 × 10
#> analysis time n event ahr theta info info0 info_frac info_frac0
#> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
#> 1 1 25.2 289. 148. 0.661 0.414 9.63 9.88 0.612 0.600
#> 2 2 36 289. 192. 0.639 0.732 15.7 16.5 1 1
#>
#> attr(,"class")
#> [1] "non_binding" "wlr" "gs_design" "list"
#> attr(,"uninteger_is_from")
#> [1] "gs_design_wlr"