[Gsdesign-commits] r362 - in pkg/gsDesign: . R inst/unitTests man vignettes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Nov 11 02:06:52 CET 2013
Author: keaven
Date: 2013-11-11 02:06:51 +0100 (Mon, 11 Nov 2013)
New Revision: 362
Modified:
pkg/gsDesign/DESCRIPTION
pkg/gsDesign/R/gsBinomial.R
pkg/gsDesign/R/gsBinomialExact.R
pkg/gsDesign/R/gsDesign.R
pkg/gsDesign/R/gsMethods.R
pkg/gsDesign/R/gsUtilities.R
pkg/gsDesign/R/gsqplot.R
pkg/gsDesign/inst/unitTests/runit.gsDesign-inputs.R
pkg/gsDesign/inst/unitTests/runit.nBinomial-inputs.R
pkg/gsDesign/inst/unitTests/runit.testBinomial-stress.R
pkg/gsDesign/man/binomial.Rd
pkg/gsDesign/man/gsBoundSummary.Rd
pkg/gsDesign/man/nSurv.Rd
pkg/gsDesign/vignettes/gsSurvTemplate.rnw
pkg/gsDesign/vignettes/gsSurvTemplateInstructions.rnw
Log:
Improved E{N} and power plots, vignette updates.
Modified: pkg/gsDesign/DESCRIPTION
===================================================================
--- pkg/gsDesign/DESCRIPTION 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/DESCRIPTION 2013-11-11 01:06:51 UTC (rev 362)
@@ -1,9 +1,9 @@
Package: gsDesign
-Version: 2.8-2
+Version: 2.8-6
Title: Group Sequential Design
Author: Keaven Anderson
Maintainer: Keaven Anderson <keaven_anderson at merck.com>
-Depends: ggplot2, xtable, stringr
+Depends: ggplot2, xtable, stringr, RUnit, plyr
Suggests: knitr
VignetteBuilder: knitr
Description: gsDesign is a package that derives group sequential designs and describes their properties.
Modified: pkg/gsDesign/R/gsBinomial.R
===================================================================
--- pkg/gsDesign/R/gsBinomial.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsBinomial.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -108,7 +108,7 @@
upper <- exp(upper)
}
}
- cbind(lower=lower,upper=upper)
+ data.frame(lower=lower,upper=upper)
}
"nBinomial" <- function(p1, p2, alpha = 0.025, beta = 0.1, delta0 = 0, ratio = 1,
Modified: pkg/gsDesign/R/gsBinomialExact.R
===================================================================
--- pkg/gsDesign/R/gsBinomialExact.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsBinomialExact.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -1,3 +1,8 @@
+#####
+# global variables used to eliminate warnings in R CMD check
+#####
+globalVariables(c("N","EN","Bound","rr","Percent","Outcome"))
+
gsBinomialExact <- function(k=2, theta=c(.1, .2), n.I=c(50, 100), a=c(3, 7), b=c(20,30))
{
checkScalar(k, "integer", c(2,Inf), inclusion=c(TRUE, FALSE))
Modified: pkg/gsDesign/R/gsDesign.R
===================================================================
--- pkg/gsDesign/R/gsDesign.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsDesign.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -31,7 +31,7 @@
# gsDProb
# gsDErrorCheck
#
-# Author(s): Keaven Anderson, PhD. timing/ Jennifer Sun, MS.
+# Author(s): Keaven Anderson, PhD. / Jennifer Sun, MS.
#
# Reviewer(s): REvolution Computing 19DEC2008 v.2.0 - William Constantine, Kellie Wills
#
@@ -1000,33 +1000,35 @@
# check input for timing of interim analyses
# if timing not specified, make it equal spacing
- if (length(x$timing) < 1 || (length(x$timing) == 1 && (x$k > 2 || (x$k == 2 && (x$timing[1] <= 0 || x$timing[1] >= 1)))))
- {
- x$timing <- seq(x$k) / x$k
- }
- # if timing specified, make sure it is done correctly
- else if (length(x$timing) == x$k - 1 || length(x$timing) == x$k)
- {
- if (length(x$timing) == x$k - 1)
- {
- x$timing <- c(x$timing, 1)
- }
- # Allowed final analysis timing to be != 1 ; KA 2009/08/15
- # else if (x$timing[x$k]!=1)
- # {
- # stop("if analysis timing for final analysis is input, it must be 1")
- # }
-
- if (min(x$timing - c(0,x$timing[1:x$k-1])) <= 0)
- {
+ # this only needs to be done if x$n.I==0; KA added 2013/11/02
+ if (max(x$n.I)==0){
+ if (length(x$timing) < 1 || (length(x$timing) == 1 && (x$k > 2 || (x$k == 2 && (x$timing[1] <= 0 || x$timing[1] >= 1)))))
+ {
+ x$timing <- seq(x$k) / x$k
+ }
+ # if timing specified, make sure it is done correctly
+ else if (length(x$timing) == x$k - 1 || length(x$timing) == x$k)
+ {
+ # put back requirement that final analysis timing must be 1, if specified; KA 2013/11/02
+ if (length(x$timing) == x$k - 1)
+ {
+ x$timing <- c(x$timing, 1)
+ }
+ else if (x$timing[x$k]!=1)
+ {
+ stop("if analysis timing for final analysis is input, it must be 1")
+ }
+
+ if (min(x$timing - c(0,x$timing[1:(x$k-1)])) <= 0)
+ {
stop("input timing of interim analyses must be increasing strictly between 0 and 1")
- }
+ }
+ }
+ else
+ {
+ stop("value input for timing must be length 1, k-1 or k")
+ }
}
- else
- {
- stop("value input for timing must be length 1, k-1 or k")
- }
-
# check input values for tol, r
checkScalar(x$tol, "numeric", c(0, 0.1), c(FALSE, TRUE))
checkScalar(x$r, "integer", c(1,80))
Modified: pkg/gsDesign/R/gsMethods.R
===================================================================
--- pkg/gsDesign/R/gsMethods.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsMethods.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -87,7 +87,7 @@
print(y)
invisible(x)
}
-"summary.gsDesign" <- function(object, information=FALSE,...){
+"summary.gsDesign" <- function(object, information=FALSE, timeunit="months",...){
out <- NULL
if (object$test.type == 1){
out<- paste(out,"One-sided group sequential design with ",sep="")
@@ -108,11 +108,17 @@
" and ", ceiling(object$n.I[object$k]), " events required, ", sep="")
}else if(information){out <- paste(out," total information ",round(object$n.I[object$k],2),", ",sep="")
}else out <- paste(out, "sample size ", ceiling(object$n.I[object$k]), ", ",sep="")
- out <- paste(out, 100 * (1 - object$beta), "% power, ", 100 * object$alpha, "% (1-sided) Type I error",sep="")
+ out <- paste(out, 100 * (1 - object$beta), " percent power, ", 100 * object$alpha, " percent (1-sided) Type I error",sep="")
+ if("gsSurv" %in% class(object)){
+ out <- paste(out," to detect a hazard ratio of ",round(object$hr,2),sep="")
+ if(object$hr0 != 1) out <- paste(out," with a null hypothesis hazard ratio of ",round(object$hr0,2),sep="")
+ out <- paste(out,". Enrollment and total study durations are assumed to be ",round(sum(object$R),1),
+ " and ",round(max(object$T),1)," ",timeunit,", respectively",sep="")
+ }
if(is.character(object$upper$sf)){
out <- paste(out, " and ",sep="")
if(object$upper$sf=="WT"){
- out <- paste(out, "Wang-Tsiatis bounds with Delta=",object$upper$param,sep="")
+ out <- paste(out, ". Wang-Tsiatis bounds with Delta=",object$upper$param,sep="")
}else if(object$upper$sf=="Pocock"){
out <- paste(out, "Pocock bounds")
}else out <- paste(out, "O'Brien-Fleming bounds",sep="")
@@ -134,9 +140,7 @@
}
}
}
- out <- paste(out,".",sep="")
- cat(str_wrap(out,...))
- invisible(out)
+ return(paste(out,".",sep=""))
}
"print.gsDesign" <- function(x, ...)
{
@@ -338,7 +342,7 @@
}
# delta values corresponding to x$theta
delta <- x$delta0 + (x$delta1-x$delta0)*x$theta/x$delta
- if (logdelta) delta <- exp(delta)
+ if (logdelta || "gsSurv" %in% class(x)) delta <- exp(delta)
# ratio is only used for RR and HR calculations at boundaries
if("gsSurv" %in% class(x)){
ratio <- x$ratio
Modified: pkg/gsDesign/R/gsUtilities.R
===================================================================
--- pkg/gsDesign/R/gsUtilities.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsUtilities.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -175,7 +175,7 @@
dot <- getwd()
setwd(dir)
- x <- tools:::md5sum(dir(dir, recursive = TRUE))
+ x <- tools::md5sum(dir(dir, recursive = TRUE))
setwd(dot)
x <- x[!(names(x) %in% ignore)]
Modified: pkg/gsDesign/R/gsqplot.R
===================================================================
--- pkg/gsDesign/R/gsqplot.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/R/gsqplot.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -32,6 +32,11 @@
#
##################################################################################
+#####
+# global variables used to eliminate warnings in R CMD check
+#####
+globalVariables(c("y","N","Z","Bound","thetaidx","Probability","delta","Analysis"))
+
###
# Exported Functions
###
@@ -465,251 +470,261 @@
}
}
"plotASN" <- function(x, xlab=NULL, ylab=NULL, main=NULL, theta=NULL, xval=NULL, type="l",
- base=FALSE,...)
+ base=FALSE,...)
{
- if (is(x, "gsDesign") && x$n.fix == 1)
- {
- if (is.null(ylab))
- {
- ylab <- "E{N} relative to fixed design"
- }
-
- if (is.null(main))
- {
- main <- "Expected sample size relative to fixed design"
- }
+ if (is(x, "gsDesign") && x$n.fix == 1)
+ {
+ if (is.null(ylab)) ylab <- "E{N} relative to fixed design"
+ if (is.null(main)) main <- "Expected sample size relative to fixed design"
+ }
+ else if (is(x, "gsSurv"))
+ {
+ if (is.null(ylab)) ylab <- "Expected number of events"
+ if (is.null(main)) main <- "Expected number of events by underlying hazard ratio"
+ }
+ else
+ {
+ if (is.null(ylab)) ylab <- "Expected sample size"
+ if (is.null(main)) main <- "Expected sample size by underlying treatment difference"
+ }
+
+ if (is.null(theta))
+ {
+ if (is(x,"gsDesign")) theta <- seq(0, 2, .05) * x$delta
+ else theta <- x$theta
+ }
+
+ if (is.null(xval)){
+ if (is(x, "gsDesign")){
+ xval <- x$delta0 + (x$delta1-x$delta0)*theta/x$delta
+ if (is(x, "gsSurv")){
+ xval <- exp(xval)
+ if (is.null(xlab)) xlab <- "Hazard ratio"
+ }else if (is.null(xlab)) xlab <- expression(delta)
+ }else{
+ xval <- theta
+ if (is.null(xlab)) xlab <- expression(theta)
}
- else if (is.null(main))
- {
- main <- "Expected sample size by treatment difference"
- }
-
- if (is.null(theta))
- {
- if (is(x,"gsDesign"))
- {
- theta <- seq(0, 2, .05) * x$delta
- }
- else
- {
- theta <- x$theta
- }
- }
-
- if (is.null(xval))
- {
- if (is(x, "gsDesign") && is.null(xlab))
- {
- xval <- theta / x$delta
-
- if (is.null(xlab))
- {
- xlab <- expression(theta / theta[1])
- }
- }
- else
- {
- xval <- theta
-
- if (is.null(xlab))
- {
- xlab <- expression(theta)
- }
- }
- }
-
- if (is.null(xlab))
- {
- xlab <- ""
- }
-
- x <- if (is(x, "gsDesign")) gsProbability(d=x, theta=theta) else
- gsProbability(k=x$k, a=x$lower$bound, b=x$upper$bound, n.I=x$n.I, theta=theta)
-
- if (is.null(ylab))
- {
- if (max(x$n.I) < 3) ylab <- "E{N} relative to fixed design"
- else ylab <- "Expected sample size"
- }
- if (base)
- { plot(xval, x$en, type=type, ylab=ylab, xlab=xlab, main=main,...)
+ }
+
+ x <- if (is(x, "gsDesign")) gsProbability(d=x, theta=theta) else
+ gsProbability(k=x$k, a=x$lower$bound, b=x$upper$bound, n.I=x$n.I, theta=theta)
+
+ if (is.null(ylab))
+ {
+ if (max(x$n.I) < 3) ylab <- "E{N} relative to fixed design"
+ else ylab <- "Expected sample size"
+ }
+ if (base)
+ { plot(xval, x$en, type=type, ylab=ylab, xlab=xlab, main=main,...)
+ return(invisible(x))
+ }
+ else
+ { q <- data.frame(x=xval, y=x$en)
+ p <- qplot(x=x, y=y, data=q, geom="line", ylab=ylab, xlab=xlab, main=main)
+ return(p)
+ }
+}
+"plotgsPower" <- function(x, main="Boundary crossing probabilities by effect size",
+ ylab="Cumulative Boundary Crossing Probability",
+ xlab=NULL, lty=NULL, col=NULL, lwd=1, cex=1,
+ theta=if (is(x, "gsDesign")) seq(0, 2, .05) * x$delta else x$theta,
+ xval=NULL, base=FALSE, outtype=1,...)
+{ ggver <- as.numeric_version(packageVersion('ggplot2'))
+ if (is.null(xval)){
+ if (is(x, "gsDesign")){
+ xval <- x$delta0 + (x$delta1-x$delta0)*theta/x$delta
+ if (is(x, "gsSurv")){
+ xval <- exp(xval)
+ if (is.null(xlab)) xlab <- "Hazard ratio"
+ }else if (is.null(xlab)) xlab <- expression(delta)
+ }else{
+ xval <- theta
+ if (is.null(xlab)) xlab <- expression(theta)
+ }
+ }
+ if (is.null(xlab)) xlab <- ""
+ x <- if (is(x, "gsDesign")) gsProbability(d=x, theta=theta) else
+ gsProbability(k=x$k, a=x$lower$bound, b=x$upper$bound, n.I=x$n.I, theta=theta)
+ test.type <- ifelse(is(x,"gsProbability"), 3, x$test.type)
+ theta <- xval
+ if (!base && outtype==1){
+ if (is.null(lty)) lty <- x$k:1
+ xu <-data.frame(x$upper$prob)
+ y <- cbind(reshape(xu, varying=names(xu), v.names="Probability", timevar="thetaidx",direction="long"), Bound="Upper bound")
+ if (is.null(col)) col<-1
+ if (is.null(x$test.type) || x$test.type > 1){
+ y <- rbind(
+ cbind(reshape(data.frame(x$lower$prob), varying=names(xu), v.names="Probability", timevar="thetaidx", direction="long"), Bound="1-Lower bound"),
+ y)
+ if (length(col)==1) col <- c(2,1)
+ }
+ y2 <- ddply(y, .(Bound, thetaidx),summarize,Probability=cumsum(Probability))
+ y2$Probability[y2$Bound=="1-Lower bound"]<-1-y2$Probability[y2$Bound=="1-Lower bound"]
+ y2$Analysis <- factor(y$id)
+ y2$delta <- xval[y$thetaidx]
+ p <- ggplot(y2,aes(x=delta,y=Probability,col=Bound,lty=Analysis))+geom_line(size=lwd)+ylab(ylab) +
+ guides(color=guide_legend(title="Probability")) + xlab(xlab) +
+ scale_linetype_manual(values=lty) +
+ scale_color_manual(values=col) +
+ scale_y_continuous(breaks=seq(0,1,.2))
+ if (ggver >= as.numeric_version("0.9.2")) return(p+ggtitle(label=main))
+ else return(p + opts(title=main))
+ }
+ if (is.null(col)){
+ if (base || outtype==2) col <- c(1,2)
+ else col <- c(2,1)
+ }
+ if (length(col==1)) col=array(col,2)
+ if (is.null(lty)){
+ if(base || outtype==2) lty <- c(1,2)
+ else lty <- c(2,1)
+ }
+ if (length(lty==1)) lty=array(lty,2)
+ if (length(lwd==1)) lwd=array(lwd,2)
+
+
+ interim <- array(1,length(xval))
+ bound <- array(1,length(xval)*x$k)
+ boundprob <- x$upper$prob[1,]
+ prob <- boundprob
+ yval <- min(mean(range(x$upper$prob[1,])))
+ xv <- ifelse(xval[2]>xval[1],min(xval[boundprob>=yval]),max(xval[boundprob>=yval]))
+ for(j in 2:x$k)
+ { theta <- c(theta, xval)
+ interim <- c(interim, array(j, length(xval)))
+ boundprob <- boundprob + x$upper$prob[j,]
+ prob <- c(prob, boundprob)
+ ymid <- mean(range(boundprob))
+ yval <- c(yval, min(boundprob[boundprob >= ymid]))
+ xv <- c(xv, ifelse(xval[2]>xval[1],min(xval[boundprob >= ymid]),max(xval[boundprob>=ymid])))
+ }
+ itxt <- array("Interim",x$k-1)
+ itxt <- paste(itxt,1:(x$k-1),sep=" ")
+
+ if (is(x, "gsProbability") || (is(x, "gsDesign") && test.type > 1))
+ {
+ itxt <- c(itxt,"Final",itxt)
+ boundprob <- array(1, length(xval))
+ bound <- c(bound, array(2, length(xval)*(x$k-1)))
+ for(j in 1:(x$k-1))
+ { theta <- c(theta, xval)
+ interim <- c(interim, array(j, length(xval)))
+ boundprob <- boundprob - x$lower$prob[j,]
+ prob <- c(prob, boundprob)
+ ymid <- mean(range(boundprob))
+ yval <- c(yval, min(boundprob[boundprob >= ymid]))
+ xv <- c(xv, ifelse(xval[2]>xval[1], min(xval[boundprob >= ymid]), max(xval[boundprob>=ymid])))
+ }
+ }else {itxt <- c(itxt,"Final")}
+ y <- data.frame(theta=as.numeric(theta), interim=interim, bound=bound, prob=as.numeric(prob),
+ itxt=as.character(round(prob,2)))
+ y$group=(y$bound==2)*x$k + y$interim
+ bound <- array(1, x$k)
+ interim <- 1:x$k
+ if (test.type > 1)
+ { bound <- c(bound, array(2, x$k-1))
+ interim <- c(interim, 1:(x$k-1))
+ }
+ yt <- data.frame(theta=xv, interim=interim, bound=bound, prob=yval, itxt=itxt)
+ bound <- array(1, x$k)
+ interim <- 1:x$k
+ if (test.type > 1)
+ { bound <- c(bound, array(2, x$k-1))
+ interim <- c(interim, 1:(x$k-1))
+ }
+ yt <- data.frame(theta=xv, interim=interim, bound=bound, prob=yval, itxt=itxt)
+ if (base)
+ { col2 <- ifelse(length(col) > 1, col[2], col)
+ lwd2 <- ifelse(length(lwd) > 1, lwd[2], lwd)
+ lty2 <- ifelse(length(lty) > 1, lty[2], lty)
+
+ ylim <- if (is(x, "gsDesign") && test.type<=2) c(0, 1) else c(0, 1.25)
+
+ plot(xval, x$upper$prob[1, ], xlab=xlab, main=main, ylab=ylab,
+ ylim=ylim, type="l", col=col[1], lty=lty[1], lwd=lwd[1], yaxt = "n")
+
+ if (is(x, "gsDesign") && test.type <= 2)
+ {
+ axis(2, seq(0, 1, 0.1))
+ axis(4, seq(0, 1, 0.1))
+ }
+ else
+ {
+ axis(4, seq(0, 1, by=0.1), col.axis=col[1], col=col[1])
+ axis(2, seq(0, 1, .1), labels=1 - seq(0, 1, .1), col.axis=col2, col=col2)
+ }
+
+ if (x$k == 1)
+ {
return(invisible(x))
- }
- else
- { q <- data.frame(x=xval, y=x$en)
- p <- qplot(x=x, y=y, data=q, geom="line", ylab=ylab, xlab=xlab, main=main)
- return(p)
- }
+ }
+
+ if ((is(x, "gsDesign") && test.type > 2) || !is(x, "gsDesign"))
+ {
+ lines(xval, 1-x$lower$prob[1, ], lty=lty2, col=col2, lwd=lwd2)
+ plo <- x$lower$prob[1, ]
+
+ for (i in 2:x$k)
+ {
+ plo <- plo + x$lower$prob[i, ]
+ lines(xval, 1 - plo, lty=lty2, col=col2, lwd=lwd2)
+ }
+
+ temp <- legend("topleft", legend = c(" ", " "), col=col,
+ text.width = max(strwidth(c("Upper","Lower"))), lwd=lwd,
+ lty = lty, xjust = 1, yjust = 1,
+ title = "Boundary")
+
+ text(temp$rect$left + temp$rect$w, temp$text$y,
+ c("Upper","Lower"), col=col, pos=2)
+ }
+
+ phi <- x$upper$prob[1, ]
+
+ for (i in 2:x$k)
+ {
+ phi <- phi + x$upper$prob[i, ]
+ lines(xval, phi, col=col[1], lwd=lwd[1], lty=lty[1])
+ }
+ colr <- array(col[1], x$k)
+ if (length(yt$theta)>x$k) colr<-c(colr,array(col[2],x$k-1))
+ text(x=yt$theta, y=yt$prob, col=colr, yt$itxt, cex=cex)
+ invisible(x)
+ }
+ else
+ { p <- ggplot(data=subset(y,interim==1),
+ aes(x=theta, y=prob, group=factor(bound),
+ col=factor(bound), lty=factor(bound))) +
+ geom_line() +
+ scale_x_continuous(xlab)+scale_y_continuous(ylab) +
+ scale_colour_manual(name= "Bound", values=col) +
+ scale_linetype_manual(name= "Bound", values=lty)
+ if (ggver >= as.numeric_version("0.9.2"))
+ { p <- p + ggtitle(label=main)}else{
+ p <- p + opts(title=main)
+ }
+ if(test.type == 1)
+ { p <- p + scale_colour_manual(name= "Probability", values=col, breaks=1,
+ labels="Upper bound") +
+ scale_linetype_manual(name="Probability", values=lty[1], breaks=1,
+ labels="Upper bound")
+ if (ggver >= as.numeric_version("0.9.2"))
+ { p <- p + ggtitle(label=main)}else{
+ p <- p + opts(title=main)
+ }
+ }else{
+ p <- p + scale_colour_manual(name= "Probability", values=col, breaks=1:2,
+ labels=c("Upper bound","1-Lower bound")) +
+ scale_linetype_manual(name="Probability", values=lty, breaks=1:2,
+ labels=c("Upper bound","1-Lower bound"))
+ }
+ p <- p + geom_text(data=yt, aes(theta, prob, colour=factor(bound), group=1, label=itxt), size=cex*5, show_guide=F)
+ for(i in 1:x$k) p <- p + geom_line(data=subset(y,interim==i&bound==1),
+ colour=col[1], lty=lty[1], lwd=lwd[1])
+ if (test.type > 2) for(i in 1:(x$k-1)) {
+ p <- p + geom_line(data=subset(y,interim==i&bound==2), colour=col[2], lty=lty[2], lwd=lwd[2])
+ }
+ return(p)
+ }
}
-"plotgsPower" <- function(x, main=NULL,
- ylab="Cumulative Boundary Crossing Probability",
- xlab=NULL, lty=c(1, 2), col=c(1, 2), lwd=1, cex=1,
- theta=if (is(x, "gsDesign")) seq(0, 2, .05) * x$delta else x$theta, xval=NULL, base=FALSE,
- ...)
-{ ggver <- as.numeric_version(packageVersion('ggplot2'))
- if (is.null(main)) main <- "Boundary crossing probabilities by effect size"
- if (length(col==1)) col=array(col,2)
- if (length(lty==1)) lty=array(lty,2)
- if (length(lwd==1)) lwd=array(lwd,2)
- if (is.null(xval))
- {
- if (is(x, "gsDesign") && is.null(xlab))
- {
- xval <- theta / x$delta
- xlab <- expression(theta/theta[1])
- }
- else
- {
- xval <- theta
- if (is.null(xlab)) xlab <- expression(theta)
- }
- }
- x <- if (is(x, "gsDesign")) gsProbability(d=x, theta=theta) else
- gsProbability(k=x$k, a=x$lower$bound, b=x$upper$bound, n.I=x$n.I, theta=theta)
- test.type <- ifelse(is(x,"gsProbability"), 3, x$test.type)
- if (is.null(xlab)) xlab <- ""
- theta <- xval
- interim <- array(1,length(xval))
- bound <- array(1,length(xval)*x$k)
- boundprob <- x$upper$prob[1,]
- prob <- boundprob
- yval <- min(mean(range(x$upper$prob[1,])))
- xv <- min(xval[boundprob>=yval])
- for(j in 2:x$k)
- { theta <- c(theta, xval)
- interim <- c(interim, array(j, length(xval)))
- boundprob <- boundprob + x$upper$prob[j,]
- prob <- c(prob, boundprob)
- ymid <- mean(range(boundprob))
- yval <- c(yval, min(boundprob[boundprob >= ymid]))
- xv <- c(xv, min(xval[boundprob >= ymid]))
- }
- itxt <- array("Interim",x$k-1)
- itxt <- paste(itxt,1:(x$k-1),sep=" ")
-
- if (is(x, "gsProbability") || (is(x, "gsDesign") && test.type > 1))
- {
- itxt <- c(itxt,"Final",itxt)
- boundprob <- array(1, length(xval))
- bound <- c(bound, array(2, length(xval)*(x$k-1)))
- for(j in 1:(x$k-1))
- { theta <- c(theta, xval)
- interim <- c(interim, array(j, length(xval)))
- boundprob <- boundprob - x$lower$prob[j,]
- prob <- c(prob, boundprob)
- ymid <- mean(range(boundprob))
- yval <- c(yval, min(boundprob[boundprob >= ymid]))
- xv <- c(xv, min(xval[boundprob >= ymid]))
- }
- }else {itxt <- c(itxt,"Final")}
- y <- data.frame(theta=as.numeric(theta), interim=interim, bound=bound, prob=as.numeric(prob),
- itxt=as.character(round(prob,2)))
- y$group=(y$bound==2)*x$k + y$interim
- bound <- array(1, x$k)
- interim <- 1:x$k
- if (test.type > 1)
- { bound <- c(bound, array(2, x$k-1))
- interim <- c(interim, 1:(x$k-1))
- }
- yt <- data.frame(theta=xv, interim=interim, bound=bound, prob=yval, itxt=itxt)
- bound <- array(1, x$k)
- interim <- 1:x$k
- if (test.type > 1)
- { bound <- c(bound, array(2, x$k-1))
- interim <- c(interim, 1:(x$k-1))
- }
- yt <- data.frame(theta=xv, interim=interim, bound=bound, prob=yval, itxt=itxt)
- if (base)
- { col2 <- ifelse(length(col) > 1, col[2], col)
- lwd2 <- ifelse(length(lwd) > 1, lwd[2], lwd)
- lty2 <- ifelse(length(lty) > 1, lty[2], lty)
-
- ylim <- if (is(x, "gsDesign") && test.type<=2) c(0, 1) else c(0, 1.25)
-
- plot(xval, x$upper$prob[1, ], xlab=xlab, main=main, ylab=ylab,
- ylim=ylim, type="l", col=col[1], lty=lty[1], lwd=lwd[1], yaxt = "n")
-
- if (is(x, "gsDesign") && test.type <= 2)
- {
- axis(2, seq(0, 1, 0.1))
- axis(4, seq(0, 1, 0.1))
- }
- else
- {
- axis(4, seq(0, 1, by=0.1), col.axis=col[1], col=col[1])
- axis(2, seq(0, 1, .1), labels=1 - seq(0, 1, .1), col.axis=col2, col=col2)
- }
-
- if (x$k == 1)
- {
- return(invisible(x))
- }
-
- if ((is(x, "gsDesign") && test.type > 2) || !is(x, "gsDesign"))
- {
- lines(xval, 1-x$lower$prob[1, ], lty=lty2, col=col2, lwd=lwd2)
- plo <- x$lower$prob[1, ]
-
- for (i in 2:x$k)
- {
- plo <- plo + x$lower$prob[i, ]
- lines(xval, 1 - plo, lty=lty2, col=col2, lwd=lwd2)
- }
-
- temp <- legend("topleft", legend = c(" ", " "), col=col,
- text.width = max(strwidth(c("Upper","Lower"))), lwd=lwd,
- lty = lty, xjust = 1, yjust = 1,
- title = "Boundary")
-
- text(temp$rect$left + temp$rect$w, temp$text$y,
- c("Upper","Lower"), col=col, pos=2)
- }
-
- phi <- x$upper$prob[1, ]
-
- for (i in 2:x$k)
- {
- phi <- phi + x$upper$prob[i, ]
- lines(xval, phi, col=col[1], lwd=lwd[1], lty=lty[1])
- }
- colr <- array(col[1], x$k)
- if (length(yt$theta)>x$k) colr<-c(colr,array(col[2],x$k-1))
- text(x=yt$theta, y=yt$prob, col=colr, yt$itxt, cex=cex)
- invisible(x)
- }
- else
- { p <- ggplot(data=subset(y,interim==1),
- aes(x=theta, y=prob, group=factor(bound),
- col=factor(bound), lty=factor(bound))) +
- geom_line() +
- scale_x_continuous(xlab)+scale_y_continuous(ylab) +
- scale_colour_manual(name= "Bound", values=col) +
- scale_linetype_manual(name= "Bound", values=lty)
- if (ggver >= as.numeric_version("0.9.2"))
- { p <- p + ggtitle(label=main)}else{
- p <- p + opts(title=main)
- }
- if(test.type == 1)
- { p <- p + scale_colour_manual(name= "Probability", values=col, breaks=1,
- labels="Upper bound") +
- scale_linetype_manual(name="Probability", values=lty[1], breaks=1,
- labels="Upper bound")
- if (ggver >= as.numeric_version("0.9.2"))
- { p <- p + ggtitle(label=main)}else{
- p <- p + opts(title=main)
- }
- }else{
- p <- p + scale_colour_manual(name= "Probability", values=col, breaks=1:2,
- labels=c("Upper bound","1-Lower bound")) +
- scale_linetype_manual(name="Probability", values=lty, breaks=1:2,
- labels=c("Upper bound","1-Lower bound"))
- }
- p <- p + geom_text(data=yt, aes(theta, prob, colour=factor(bound), group=1, label=itxt), size=cex*5, show_guide=F)
- for(i in 1:x$k) p <- p + geom_line(data=subset(y,interim==i&bound==1),
- colour=col[1], lty=lty[1], lwd=lwd[1])
- if (test.type > 2) for(i in 1:(x$k-1)) {
- p <- p + geom_line(data=subset(y,interim==i&bound==2), colour=col[2], lty=lty[2], lwd=lwd[2])
- }
- return(p)
- }
-}
Modified: pkg/gsDesign/inst/unitTests/runit.gsDesign-inputs.R
===================================================================
--- pkg/gsDesign/inst/unitTests/runit.gsDesign-inputs.R 2013-10-17 17:58:45 UTC (rev 361)
+++ pkg/gsDesign/inst/unitTests/runit.gsDesign-inputs.R 2013-11-11 01:06:51 UTC (rev 362)
@@ -1,126 +1,126 @@
-# gsDesign test functions
-
-"test.gsDesign.k" <- function()
-{
- checkException(gsDesign(k="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(k=1.2), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(k=0), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(k=24, test.type=4), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(k=seq(2)), msg="Checking for incorrect variable length", silent=TRUE)
- checkException(gsDesign(k=3, sfu=sfpoints, sfupar=c(.05, .1, .15, .2, 1)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.test.type" <- function()
-{
- checkException(gsDesign(test.type="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(test.type=1.2), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(test.type=0), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(test.type=7), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(test.type=seq(2)), msg="Checking for incorrect variable length", silent=TRUE)
- checkException(gsDesign(test.type=3, sfu="WT"), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(test.type=4, sfu="WT"), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(test.type=5, sfu="WT"), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(test.type=6, sfu="WT"), msg="Checking for out-of-range variable value", silent=TRUE)
-}
-
-"test.gsDesign.alpha" <- function()
-{
- checkException(gsDesign(alpha="abc", test.type=1), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(alpha=0, test.type=1), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(alpha=1, test.type=1), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(alpha=0.51, test.type=2), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(alpha=rep(0.5, 2), test.type=1), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.beta" <- function()
-{
- checkException(gsDesign(beta="abc", test.type=3), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(beta=0.5, alpha=0.5, test.type=3), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(beta=1, alpha=0, test.type=3), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(beta=0, test.type=3), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(beta=rep(0.1, 2), alpha=0.5, test.type=3), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.astar" <- function()
-{
- checkException(gsDesign(astar="abc", test.type=5), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(astar=0.51, alpha=0.5, test.type=5), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(astar=1, alpha=0, test.type=5), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(astar=-1, test.type=6), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(astar=rep(0.1, 2), alpha=0.5, test.type=5), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.delta" <- function()
-{
- checkException(gsDesign(delta="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(delta=-1), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(delta=rep(0.1, 2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.n.fix" <- function()
-{
- checkException(gsDesign(n.fix="abc", delta=0), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(n.fix=-1, delta=0), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(n.fix=rep(2, 2), delta=0), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.timing" <- function()
-{
- checkException(gsDesign(timing="abc", k=1), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(timing=-1, k=1), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(timing=2, k=1), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(timing=c(0.1, 1.1), k=2), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(timing=c(0.5, 0.1), k=2), msg="NA", silent=TRUE)
- checkException(gsDesign(timing=c(0.1, 0.5, 1), k=2), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.sfu" <- function()
-{
- checkException(gsDesign(sfu="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(sfu=rep(sfHSD, 2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.sfupar" <- function()
-{
- checkException(gsDesign(sfupar="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(sfupar=rep(-4,2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.sfl" <- function()
-{
- checkException(gsDesign(sfl="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(sfl=rep(sfHSD, 2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.sflpar" <- function()
-{
- checkException(gsDesign(sflpar="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(sflpar=rep(-2,2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.tol" <- function()
-{
- checkException(gsDesign(tol="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(tol=0), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(tol=0.10000001), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(tol=rep(0.1, 2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.r" <- function()
-{
- checkException(gsDesign(r="abc"), msg="Checking for incorrect variable type", silent=TRUE)
- checkException(gsDesign(r=0), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(r=81), msg="Checking for out-of-range variable value", silent=TRUE)
- checkException(gsDesign(r=rep(1,2)), msg="Checking for incorrect variable length", silent=TRUE)
-}
-
-"test.gsDesign.n.I" <- function()
-{
- checkException(gsDesign(n.I="abc"), msg="Checking for incorrect variable type", silent=TRUE)
-}
-
-"test.gsDesign.maxn.I" <- function()
-{
- checkException(gsDesign(maxn.I="abc"), msg="Checking for incorrect variable type", silent=TRUE)
-}
-
+# gsDesign test functions
+
+"test.gsDesign.k" <- function()
+{
+ checkException(gsDesign(k="abc"), msg="Checking for incorrect variable type", silent=TRUE)
+ checkException(gsDesign(k=1.2), msg="Checking for incorrect variable type", silent=TRUE)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/gsdesign -r 362
More information about the Gsdesign-commits
mailing list