Skip to content

Commit 1af7f37

Browse files
author
NightlordTW
committed
add more unit tests; write Cpp code for cross-over design
1 parent 90e1f83 commit 1af7f37

26 files changed

+877
-343
lines changed

‎R/RcppExports.R‎

Lines changed: 120 additions & 47 deletions
Large diffs are not rendered by default.

‎R/SampleSize.R‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -447,7 +447,6 @@ sampleSize <- function(mu_list, varcov_list = NA, sigma_list = NA, cor_mat = NA,
447447
list_y_comparator = list_y_comparator,
448448
list_lequi.tol = list_lequi.tol,
449449
list_uequi.tol = list_uequi.tol,
450-
sigmaB = sigmaB,
451450
Eper = Eper, Eco = Eco)
452451

453452
if (lognorm == TRUE & ctype == "DOM"){
@@ -570,6 +569,7 @@ sampleSize <- function(mu_list, varcov_list = NA, sigma_list = NA, cor_mat = NA,
570569
#' @param verbose Logical, if `TRUE`, displays messages about the derivation process.
571570
#'
572571
#' @return A vector of arm names.
572+
#' @keywords internal
573573
derive_arm_names <- function(arm_names, mu_list, verbose = FALSE) {
574574

575575
# Check if arm_names is missing and attempt to derive from mu_list
@@ -601,6 +601,7 @@ derive_arm_names <- function(arm_names, mu_list, verbose = FALSE) {
601601
#' @param verbose Logical, if `TRUE`, displays messages about the derivation process.
602602
#'
603603
#' @return A list of endpoint names for each arm.
604+
#' @keywords internal
604605
derive_endpoint_names <- function(ynames_list, mu_list, verbose = FALSE) {
605606

606607
# Check if ynames_list is missing and attempt to derive from mu_list
@@ -647,6 +648,7 @@ derive_endpoint_names <- function(ynames_list, mu_list, verbose = FALSE) {
647648
#' @return A named list representing the treatment allocation rate for each arm.
648649
#'
649650
#' @author Thomas Debray \email{[email protected]}
651+
#' @keywords internal
650652
derive_allocation_rate <- function(TAR = NULL, arm_names, verbose = FALSE) {
651653

652654
n_arms <- length(arm_names)
@@ -703,6 +705,7 @@ derive_allocation_rate <- function(TAR = NULL, arm_names, verbose = FALSE) {
703705
#' @return A list of variance-covariance matrices, one for each treatment arm.
704706
#'
705707
#' @author Thomas Debray \email{[email protected]}
708+
#' @keywords internal
706709
derive_varcov_list <- function(mu_list, sigma_list, ynames_list, varcov_list = NULL, cor_mat = NULL, rho = 0) {
707710
# Check if variance-covariance matrix is missing
708711
if (any(is.na(varcov_list))) {

‎R/utils.R‎

Lines changed: 32 additions & 113 deletions
Original file line numberDiff line numberDiff line change
@@ -65,7 +65,7 @@ power_cal <- function(n,nsim,param,param.d,seed,ncores){
6565
size[size < 2] <- 2
6666
size_ndrop <- ceiling((1 - param.d$dropout[names(size)])*size)
6767
size_ndrop[size_ndrop < 2] <- 2
68-
n_drop <- sum(size)-sum(size_ndrop)
68+
n_drop <- sum(size) - sum(size_ndrop)
6969

7070
} else if (param.d$dtype == "2x2") {
7171
# expected
@@ -199,6 +199,7 @@ test_studies <- function(nsim, n, comp, param, param.d, arm_seed, ncores){
199199
}
200200

201201
if(param.d$ctype=="ROM"&param.d$lognorm == TRUE){
202+
# Convert data to lognorm scale
202203
if (param.d$dtype == "parallel"){
203204
SigmaT <- as.matrix(log(SigmaT/(muT%*%t(muT))+1))
204205
SigmaR <- as.matrix(log(SigmaR/(muR%*%t(muR))+1))
@@ -214,125 +215,42 @@ test_studies <- function(nsim, n, comp, param, param.d, arm_seed, ncores){
214215
uequi.tol <- log(uequi.tol)
215216
}
216217

217-
# Get typey the positions of the primarly in C++
218-
if (any(param$type_y[endp] == 1) ) {
219-
typey <- which(param$type_y[endp] == 1) - 1
220-
} else { # in case no primary endpoint is specified
221-
typey = -1
222-
}
223-
224218
# Use C++ code to run the simulations for parallel design
225-
if (ncores == 1 & param.d$dtype == "parallel") {
219+
if (param.d$dtype == "parallel") {
226220
result <- run_simulations_par(nsim = nsim, n = n, muT = muT, muR = muR,
227-
SigmaT = as.matrix(SigmaT),
228-
SigmaR = as.matrix(SigmaR),
229-
lequi_tol = lequi.tol, uequi_tol = uequi.tol,
230-
alpha = alpha,
231-
dropout = as.numeric(c(dropout[treat1], dropout[treat2])),
232-
typey = typey,
233-
adseq = param.d$adjust == "seq", k = k,
234-
arm_seed_T = arm_seed[,treat1],
235-
arm_seed_R = arm_seed[,treat2],
236-
ctype = param.d$ctype,
237-
lognorm = param.d$lognorm,
238-
TART = param$TAR_list[[treat1]],
239-
TARR = param$TAR_list[[treat2]],
240-
vareq = param.d$vareq)
221+
SigmaT = as.matrix(SigmaT),
222+
SigmaR = as.matrix(SigmaR),
223+
lequi_tol = lequi.tol, uequi_tol = uequi.tol,
224+
alpha = alpha,
225+
dropout = as.numeric(c(dropout[treat1], dropout[treat2])),
226+
typey = param$type_y,
227+
adseq = param.d$adjust == "seq", k = k,
228+
arm_seed_T = arm_seed[,treat1],
229+
arm_seed_R = arm_seed[,treat2],
230+
ctype = param.d$ctype,
231+
lognorm = param.d$lognorm,
232+
TART = param$TAR_list[[treat1]],
233+
TARR = param$TAR_list[[treat2]],
234+
vareq = param.d$vareq)
235+
} else { # 2x2 cross-over design
236+
result <- run_simulations_2x2(nsim = nsim, ctype = param.d$ctype,
237+
lognorm = param.d$lognorm,
238+
n = n, muT = muT, muR = muR,
239+
SigmaW = as.matrix(SigmaW),
240+
lequi_tol = lequi.tol, uequi_tol = uequi.tol,
241+
alpha = alpha, sigmaB = sigmaB,
242+
dropout = dropout,
243+
Eper = param$Eper, Eco = param$Eco,
244+
typey = param$type_y,
245+
adseq = param.d$adjust == "seq", k = k,
246+
arm_seed = arm_seed[,comp])
247+
}
241248
rownames(result) <- paste0(c("totaly", endp,
242-
paste0("mu_",endp,"_",treat1),
243-
paste0("mu_",endp,"_",treat2),
244-
paste0("sd_",endp,"_",treat1),
245-
paste0("sd_",endp,"_",treat1)),"Comp:",treat1," vs ",treat2)
246-
return(result)
247-
}
248-
249-
result <- mcsapply(1:nsim, function(i){
250-
arm_seedx <- arm_seed[i,]
251-
if(param.d$dtype == "parallel" ) {
252-
if(param.d$ctype == "DOM"|(param.d$ctype=="ROM"&param.d$lognorm == TRUE) ) {
253-
outtest <- as.vector(test_par_dom(n = n, muT=muT, muR = muR,
254-
SigmaT = as.matrix(SigmaT),
255-
SigmaR = as.matrix(SigmaR),
256-
lequi_tol = lequi.tol ,uequi_tol = uequi.tol,
257-
alpha = alpha, k = k,
258-
dropout = as.numeric(c(dropout[treat1], dropout[treat2])),
259-
typey = typey,
260-
adseq = param.d$adjust == "seq",
261-
arm_seedT = arm_seedx[treat1],
262-
arm_seedR = arm_seedx[treat2],
263-
TART = param$TAR_list[[treat1]],
264-
TARR = param$TAR_list[[treat2]],
265-
vareq =param.d$vareq))
266-
267-
268-
}else{ #ROM & normal distribution
269-
outtest <- as.vector(test_par_rom(n=n, muT=muT, muR =muR,
270-
SigmaT = as.matrix(SigmaT),
271-
SigmaR = as.matrix(SigmaR),
272-
lequi_tol = lequi.tol,
273-
uequi_tol = uequi.tol,
274-
alpha = alpha, k = k,
275-
dropout = as.numeric(c(dropout[treat1],dropout[treat2])),
276-
typey = typey,
277-
adseq = param.d$adjust=="seq",
278-
arm_seedT = arm_seedx[treat1],
279-
arm_seedR = arm_seedx[treat2],
280-
TART = param$TAR_list[[treat1]],
281-
TARR = param$TAR_list[[treat2]],
282-
vareq =param.d$vareq))
283-
}
284-
285-
names(outtest) <- paste0(c("totaly", endp,
286249
paste0("mu_",endp,"_",treat1),
287250
paste0("mu_",endp,"_",treat2),
288251
paste0("sd_",endp,"_",treat1),
289252
paste0("sd_",endp,"_",treat1)),"Comp:",treat1," vs ",treat2)
290-
291-
}else{ # 2X2
292-
if(param.d$ctype == "DOM"|(param.d$ctype=="ROM"&param.d$lognorm == TRUE)){
293-
outtest <- as.vector(test_2x2_dom(n=n, muT=muT, muR=muR,
294-
SigmaW = as.matrix(SigmaW),
295-
lequi_tol = lequi.tol,
296-
uequi_tol = uequi.tol,
297-
sigmaB= sigmaB,
298-
dropout=dropout,
299-
typey = typey,
300-
adseq=param.d$adjust=="seq",
301-
Eper = param$Eper, Eco=param$Eco,
302-
arm_seed = arm_seedx[comp],
303-
alpha = alpha,
304-
k=k))
305-
names(outtest) <- paste0(c("totaly", endp,
306-
paste0("mu_",endp,"_",treat1),
307-
paste0("mu_",endp,"_",treat2),
308-
paste0("sdw_",endp,"_",treat1),
309-
paste0("sdb_",endp,"_",treat1)),"Comp:",treat1," vs ",treat2)
310-
311-
}else{ #ROM & normal distribution
312-
outtest <- as.vector(test_2x2_rom(n=n, muT=muT, muR=muR,
313-
SigmaW=as.matrix(SigmaW),
314-
lequi_tol = lequi.tol,
315-
uequi_tol = uequi.tol,
316-
sigmaB= sigmaB,
317-
dropout=dropout,
318-
typey = typey,
319-
adseq=param.d$adjust=="seq",
320-
Eper=param$Eper, Eco=param$Eco, arm_seed=arm_seedx[comp],
321-
alpha=alpha,
322-
k=k))
323-
324-
}
325-
names(outtest) <- paste0(c("totaly", endp,
326-
paste0("mu_",endp,"_",treat1),
327-
paste0("mu_",endp,"_",treat2),
328-
paste0("sdw_",endp,"_",treat1),
329-
paste0("sdb_",endp,"_",treat1)),"Comp:",treat1," vs ",treat2)
330-
331-
}
332-
333-
outtest
334-
}, mc.cores = ncores)
335-
return(result)
253+
return(result)
336254
}
337255

338256

@@ -493,6 +411,7 @@ mcsapply <- function (X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
493411
#' @param verbose Logical, if `TRUE`, the message is displayed; if `FALSE`, the message is suppressed.
494412
#'
495413
#' @return NULL (invisible). This function is used for side effects (displaying messages).
414+
#' @keywords internal
496415
info_msg <- function(message, verbose) {
497416
if (verbose) message(message)
498417
}

‎R/validation.R‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99
#' @param upper Numeric. The initial upper limit for the search range.
1010
#'
1111
#' @return NULL. If the checks pass, the function returns nothing. If the checks fail, it stops execution with an error message.
12+
#' @keywords internal
1213
validate_sample_size_limits <- function(lower, upper) {
1314

1415
# Check if both lower and upper are numeric
@@ -43,6 +44,7 @@ validate_sample_size_limits <- function(lower, upper) {
4344
#' @param varcov_list List of matrices. Each matrix is checked to ensure it is symmetric and positive semi-definite.
4445
#'
4546
#' @return NULL. If all matrices pass, the function returns nothing. If any matrix fails, it stops with an error message.
47+
#' @keywords internal
4648
validate_positive_definite <- function(varcov_list) {
4749
# Function to check if a matrix is positive semi-definite
4850
is_positive <- function(x) {

‎man/check_equivalence.Rd‎

Lines changed: 6 additions & 5 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/derive_allocation_rate.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/derive_arm_names.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/derive_endpoint_names.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/derive_varcov_list.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/info_msg.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)