Nothing
#' @include issue.R
#' @include randSeq.R
#' @include chronBias.R
#' @include corGuess.R
#' @include util.R
#' @include endpoint.R
#' @include assess.R
NULL
###############################################
# --------------------------------------------#
# Class comparison #
# --------------------------------------------#
###############################################
# --------------------------------------------
# Function for validity check
# --------------------------------------------
# Validity check function for objects of the comparison class
#
# @inheritParams overview
#
# @return Returns a \code{TRUE}, if the settings of the object are valid.
validateComparison <- function(object) {
errors <- character()
if(length(errors) == 0) TRUE else errors
}
# --------------------------------------------
# Class definition for comparison
# --------------------------------------------
# Randomization parameters generic
setClass("comparison",
slots = c(S = "data.frame", L = "list"),
validity = validateComparison)
# --------------------------------------------
# Accesssor functions for comparison
# --------------------------------------------
#' Method defining the $ operator for the assessment class
#' @keywords internal
#' @inheritParams overview
setMethod("$", "comparison",
function(x, name) slot(x, name))
# --------------------------------------------
# Show function for comparison
# --------------------------------------------
setMethod("show", "comparison", function(object) {
validObject(object)
# headline
cat("\nComparison for ", colnames(object$L[[1]]$D)[3],"\n\n", sep = "")
print(round(object@S, digits = 3))
cat("\n")
})
# --------------------------------------------
# Generic functions for using objects of type issue and randSeq
# --------------------------------------------
#' Comparison of randomization procedures
#'
#' Compares randomization procedures based on a specified issue
#' in clinical trials.
#'
#' @param issue object of class \code{issue}.
#' @param endp object of class \code{endpoint}, or \code{missing}.
#' @param ... at least one object of class \code{randSeq} or a list of
#' objects of class \code{randSeq}.
#'
#' @details
#' Randomization procedures behave differently with respect to issues
#' like selection bias, chronological bias, or loss in power estimation.
#' The \code{compare} function evaluates the behavior of randomization
#' procedures with respect to one issue.
#' Its first argument should represent one of the implemented
#' \code{\link{issues}}.
#' The second argument should be any number of objects of the class
#' \code{randSeq}. These objects represent the randomization procedures
#' for the planned comparison.
#' The last argument \code{endp} may be provided if
#' the assessment should take the distribution of the treatment groups
#' into account, e.g. for power evaluation.
#'
#' @examples
#' # compare Random Allocation Rule and Big Stick for N = 4 with respect to
#' # correct guesses
#' RAR <- getAllSeq(rarPar(4))
#' BSD <- getAllSeq(bsdPar(4, mti = 2))
#' corGuess <- corGuess("CS")
#' (comp <- compare(corGuess, RAR, BSD))
#' plot(comp)
#'
#' # compare the same procedures with respect to selection bias for a normal endpoint
#' endp <- normEndp(c(2, 2), c(1, 1))
#' selBias <- selBias("CS", 4, "exact")
#' (comp <- compare(selBias, RAR, BSD, endp = endp))
#' plot(comp)
#'
#' # compare the same procedures with respect to selection bias for an exponential endpoint
#' endp <- expEndp(lambda = c(0.5, 0.5), cenRate=0.1, accrualTime=1, cenTime=5)
#' selBias <- selBias("CS", 0.1, "exact")
#' (comp <- compare(selBias, RAR, BSD, endp = endp))
#' plot(comp)
#'
#' @return
#' \code{S4} object of class \code{comparison} summarizing the comparison of the
#' randomization procedures.
#'
#' @seealso Representation of randomization procedures: \code{\link{randPar}}
#' @seealso Generation of randomization sequences: \code{\link{genSeq}}
#' @seealso \code{\link{issues}} for the assessment of randomization sequences
#'
#' @name compare
NULL
#' @rdname compare
#'
#' @export
setGeneric("compare", function(issue, ..., endp) standardGeneric("compare"))
#' Generic plotting of comparison objects
#'
#' @param x object of class \code{comparison}.
#' @param y character \code{"boxplot"}, or \code{"violin"}, or \code{"missing"}.
#' @param ... \code{"missing"}
#'
#' @details
#' Creates a box- or violinplot of an object \code{x} of the class \code{comparison}.
#'
#' @return
#' A plot created with the additional package \code{ggplot2}.
#'
#' @examples
#' # compare Random Allocation Rule and Big Stick for N = 4 with respect to
#' # correct guesses
#' RAR <- getAllSeq(rarPar(4))
#' BSD <- getAllSeq(bsdPar(4, mti = 2))
#' corGuess <- corGuess("CS")
#' comp <- compare(corGuess, RAR, BSD)
#' plot(comp)
#'
#' @seealso \code{\link{compare}} for creating \code{S4} objects of the class \code{comparison}
#'
#' @name plot
NULL
#' @rdname plot
#'
#' @export
setGeneric("plot")
# --------------------------------------------
# Methods for assessment
# --------------------------------------------
#' @rdname compare
setMethod("compare", signature(issue = "issue", endp = "missing"),
function(issue, ...) {
R <- list(...)
if (length(R) == 1 && is.list(R[[1]])) {
R <- c(...)
}
if (!all(sapply(R, function(x) is(x, "randSeq"))))
stop("Not all ... objects of class randSeq.")
#if (!all(sapply(R, function(x) identical(x@K, 2))))
#stop("Not all ... objects have K = 2.")
#if (!all(sapply(R, function(x) identical(x@ratio, c(1, 1)))))
# stop("Not all ... objects have ratio = c(1, 1).")
output <- lapply(R, function(r) {
assess(r, issue)
})
names <- lapply(output, function(x) {
x$design
})
S <- do.call("cbind", lapply(output, function(x) {
summary(x)
}))
colnames(S) <- names
new("comparison", S = data.frame(S), L = output)
}
)
#' @rdname compare
setMethod("compare", signature(issue = "issue", endp = "endpoint"),
function(issue, ..., endp) {
R <- list(...)
if (length(R) == 1 && is.list(R[[1]])) {
R <- c(...)
}
if (!all(sapply(R, function(x) is(x, "randSeq"))))
stop("Not all ... objects of class randSeq.")
#if (!all(sapply(R, function(x) identical(x@K, 2))))
#stop("Not all ... objects have K = 2.")
#if (!all(sapply(R, function(x) identical(x@ratio, c(1, 1)))))
#stop("Not all ... objects have ratio = c(1, 1).")
output <- lapply(R, function(r) {
assess(r, issue, endp = endp)
})
names <- lapply(output, function(x) {
x$design
})
S <- do.call("cbind", lapply(output, function(x) {
summary(x)
}))
colnames(S) <- names
new("comparison", S = data.frame(S), L = output)
}
)
# --------------------------------------------
# Plot function for comparison
# --------------------------------------------
#' @rdname plot
setMethod("plot", c("comparison","character"), function(x,y) {
Probability <- design <- NULL
obj <- do.call("rbind", lapply(x@L, function(z) {
D <- z@D
if (sum(!duplicated(D[,3])) == 1 && y == "violin") {
stop(paste("Violin plot not possible. All entries for", colnames(D)[3], "in", z@design, "are the same."))
}
D$Sequence <- NULL
colnames(D)[1] <- "Probability"
D$design <- z@design
D
}
))
xName <- colnames(obj)[2]
colnames(obj)[2]<- "x"
if (is.logical(obj$x)) {
warning("Issue is measured on a logical scale. Method should be adjusted to exact instead of sim.")
}
g <- ggplot(obj, aes(x = design, y = x, weight = Probability))
if (y == "boxplot") {
g <- g + geom_boxplot(aes(fill = design))
}
else {
g <- g + geom_violin(aes(fill = design))
}
g <- g + theme(legend.position = "none")
g <- g + scale_y_continuous(name = xName)
g <- g + scale_x_discrete(name = "Randomization Procedures")
plot(g)
})
#' @rdname plot
setMethod("plot", c("comparison","missing"), function(x,y) {
Probability <- design <- NULL
obj <- do.call("rbind", lapply(x@L, function(z) {
D <- z@D
if (sum(!duplicated(D[,3])) == 1 && y == "violin") {
stop(paste("Violin plot not possible. All entries for", colnames(D)[3], "in", z@design, "are the same."))
}
D$Sequence <- NULL
colnames(D)[1] <- "Probability"
D$design <- z@design
D
}
))
xName <- colnames(obj)[2]
colnames(obj)[2]<- "x"
if (is.logical(obj$x)) {
warning("Issue is measured on a logical scale. Method should be adjusted to exact instead of sim.")
}
g <- ggplot(obj, aes(x = design, y = x, weight = Probability))
g <- g + geom_violin(aes(fill = design))
g <- g + theme(legend.position = "none")
g <- g + scale_y_continuous(name = xName)
g <- g + scale_x_discrete(name = "Randomization Procedures")
plot(g)
})
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.