Nothing
#' @include randPar.R
NULL
###############################################
# --------------------------------------------#
# Class udPar #
# --------------------------------------------#
###############################################
# --------------------------------------------
# Function for validity check
# --------------------------------------------
# Validity check function for objects of the tbdPar class
#
# @inheritParams overview
#
# @return Returns a \code{TRUE}, if the settings of the object are valid.
validateudpar <- function(object) {
errors <- character()
ini <- object@ini
add <- object@add
if(length(ini) != 1) {
msg <- paste("ini has length ", length(ini), ". Should be length one.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if (round(ini[1]) != ini) {
msg <- paste("First element of ini is ", ini, ". Should be an integer.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if (ini[1] < 0) {
msg <- paste("First element of ini is negative should be positive.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if(length(add) != 1) {
msg <- paste("add has length ", length(add), ". Should be length one.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if (round(add[1]) != add) {
msg <- paste("First element of add is ", add, ". Should be an integer.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if (add[1] <= 0) {
msg <- paste("First element of add is negative or zero should be positive.",
sep = "", collapse = "")
errors <- c(errors, msg)
}
if(length(errors) == 0) TRUE else errors
}
# --------------------------------------------
# Class definition for udPar
# --------------------------------------------
# Randomization parameters generic
setClass("udPar",
slots = c(ini = "numeric", add = "numeric"),
contains = "randPar",
validity = validateudpar)
# --------------------------------------------
# Constructor function for udPar
# --------------------------------------------
#' Representing Wei's Urn Design
#'
#' Represents Wei's Urn Design.
#'
#' @details
#' An urn is filled with a number of \code{ini} balls of both of the treatments.
#' Afterwards, a ball is drawn randomly from the urn. Finally, \code{add} balls
#' are added to the urn from the opposite treatment. This procedure is repeated until
#' \code{N} patients are assigned.
#'
#' @family randomization procedures
#'
#' @inheritParams overview
#'
#' @return
#' \code{S4} object of the class \code{udPar}.
#'
#' @export
#'
#' @references
#' L.J. Wei (1977) A Class of Designs for Sequential Clinical Trials.
#' \emph{Journal of the American Statistical Association}, \strong{72}, 382-6.
udPar <- function(N, ini, add, groups = LETTERS[1:2]) {
new("udPar", N = N, ini = ini, add = add, K = 2, ratio = c(1, 1),
groups = groups)
}
# --------------------------------------------
# Sampling algorithm for UD
# --------------------------------------------
# Wei's Urn design
#
# Computes a randomization sequence based on Weis Urn Design
#
# @inheritParams overview
# @param ini integer representing the initial urn composition.
# @param add integer representing the number of balls that are added to the
# urn in each step.
#
# @return A vector with the allocation sequence for a clinical trial.
# It will contain a zero (resp. 1) at position \code{i}, when patient \code{i}
# is allocated to treatment A (resp. B).
#
# @export
urnRand <- function(N, ini, add) {
R <- numeric(N)
R[1] <- sample(c(0, 1), size = 1)
sumR <- R[1]
for(j in 1:(N-1)) {
R[j + 1] <- rbinom(1, 1, prob = (ini + add*(j-sumR))/(2*ini + add*j))
sumR <- sumR + R[j+1]
}
R
}
# --------------------------------------------
# Methods for udPar
# --------------------------------------------
#' @rdname generateAllSequences
setMethod("getAllSeq", signature(obj = "udPar"),
function(obj) {
if(obj@ini == 0) {
allSeqs <- compltSet(obj)
inside <- apply(allSeqs, 1, function(x) {
if(sum(x[1:2]) %in% c(0, 2)) {
FALSE
} else {
TRUE
}
})
M = allSeqs[inside, ]
} else {
M = compltSet(obj)
}
new("udSeq",
M = M,
N = N(obj),
ini = obj@ini,
add = obj@add,
ratio = obj@ratio,
groups = obj@groups,
K = K(obj))
}
)
#' @rdname generateRandomSequences
setMethod("genSeq", signature(obj = "udPar", r = "numeric", seed = "numeric"),
function(obj, r, seed) {
set.seed(seed)
new("rUdSeq",
M = t(sapply(1:r, function(x) {
urnRand(N(obj), obj@ini, obj@add)
})),
N = N(obj),
ini = obj@ini,
add = obj@add,
K = K(obj),
ratio = obj@ratio,
groups = obj@groups,
seed = seed)
}
)
#' @rdname generateRandomSequences
setMethod("genSeq", signature(obj = "udPar", r = "missing", seed = "numeric"),
function(obj, r, seed) {
set.seed(seed)
if(K(obj) > 2) stop("UD: K>2 not available.")
new("rUdSeq",
M = t(urnRand(N(obj), obj@ini, obj@add)),
N = N(obj),
ini = obj@ini,
add = obj@add,
K = K(obj),
ratio = obj@ratio,
groups = obj@groups,
seed = seed)
}
)
#' @rdname generateRandomSequences
setMethod("genSeq", signature(obj = "udPar", r = "numeric", seed = "missing"),
function(obj, r, seed) {
seed <- sample(.Machine$integer.max, 1)
set.seed(seed)
new("rUdSeq",
M = t(sapply(1:r,function(x) {
urnRand(N(obj), obj@ini, obj@add)
})),
N = N(obj),
ini = obj@ini,
add = obj@add,
K = K(obj),
ratio = obj@ratio,
groups = obj@groups,
seed = seed)
}
)
#' @rdname generateRandomSequences
setMethod("genSeq", signature(obj = "udPar", r = "missing", seed = "missing"),
function(obj, r, seed) {
seed <- sample(.Machine$integer.max, 1)
set.seed(seed)
if(K(obj) > 2) stop("UD: K>2 not available.")
new("rUdSeq",
M = t(urnRand(N(obj), obj@ini, obj@add)),
N = N(obj),
ini = obj@ini,
add = obj@add,
K = K(obj),
ratio = obj@ratio,
groups = obj@groups,
seed = seed)
}
)
#' @rdname getDesign
setMethod("getDesign",
signature(obj = "udPar"),
function(obj) {
paste("UD(", obj@ini, ",", obj@add, ")", sep = "")
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.