From noreply at r-forge.r-project.org Mon Nov 11 02:06:52 2013 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 11 Nov 2013 02:06:52 +0100 (CET) Subject: [Gsdesign-commits] r362 - in pkg/gsDesign: . R inst/unitTests man vignettes Message-ID: <20131111010652.3DBC71861EC@r-forge.r-project.org> 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 -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