[Gsdesign-commits] r345 - in pkg/gsDesign: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 14 22:41:25 CET 2013
Author: keaven
Date: 2013-03-14 22:41:24 +0100 (Thu, 14 Mar 2013)
New Revision: 345
Modified:
pkg/gsDesign/DESCRIPTION
pkg/gsDesign/R/gsUtilities.R
Log:
Removed use of .find.package in gsUtilities.R
Modified: pkg/gsDesign/DESCRIPTION
===================================================================
--- pkg/gsDesign/DESCRIPTION 2013-02-22 10:07:11 UTC (rev 344)
+++ pkg/gsDesign/DESCRIPTION 2013-03-14 21:41:24 UTC (rev 345)
@@ -1,5 +1,5 @@
Package: gsDesign
-Version: 2.7-05
+Version: 2.7-06
Title: Group Sequential Design
Author: Keaven Anderson
Maintainer: Keaven Anderson <keaven_anderson at merck.com>
Modified: pkg/gsDesign/R/gsUtilities.R
===================================================================
--- pkg/gsDesign/R/gsUtilities.R 2013-02-22 10:07:11 UTC (rev 344)
+++ pkg/gsDesign/R/gsUtilities.R 2013-03-14 21:41:24 UTC (rev 345)
@@ -1,198 +1,249 @@
-##################################################################################
-# Validation functionality for the gsDesign package
-#
-# Exported Functions:
-#
-# checkLengths
-# checkRange
-# checkScalar
-# checkVector
-# isInteger
-#
-# Hidden Functions:
-#
-# checkMD5
-#
-# Author(s): William Constantine, Ph.D.
-#
-# Reviewer(s): REvolution Computing 19DEC2008 v.2.0 - William Constantine, Kellie Wills
-#
-# R Version: 2.7.2
-#
-##################################################################################
-
-###
-# Exported Functions
-###
-
-"checkLengths" <- function(..., allowSingle=FALSE)
-{
- lens <- unlist(lapply(list(...),length))
-
- if (allowSingle)
- {
- lens <- lens[lens > 1]
- }
-
- if (length(lens) > 0 && length(unique(lens)) != 1)
- {
- parent <- as.character(sys.call(-1)[[1]])
- stop(if (length(parent) > 0) paste("In function", parent, ":") else "",
- "lengths of inputs are not all equal")
- }
-
- invisible(NULL)
-}
-
-"checkRange" <- function(x, interval = 0:1, inclusion = c(TRUE, TRUE), varname = deparse(substitute(x)),
- tol=0)
-{
- # check inputs
- checkVector(interval, "numeric")
- if (length(interval) != 2)
- {
- stop("Interval input must contain two elements")
- }
-
- interval <- sort(interval)
- checkVector(inclusion, "logical")
- inclusion <- if (length(inclusion) == 1) rep(inclusion, 2) else inclusion[1:2]
-
- xrange <- range(x)
- left <- ifelse(inclusion[1], xrange[1] >= interval[1] - tol, xrange[1] > interval[1] - tol)
- right <- ifelse(inclusion[2], xrange[2] <= interval[2] + tol, xrange[2] < interval[2] + tol)
-
- if (!(left && right))
- {
- stop(paste(varname, " not on interval ", if (inclusion[1]) "[" else "(", interval[1], ", ",
- interval[2], if (inclusion[2]) "]" else ")", sep=""))
- }
-
- invisible(NULL)
-}
-
-"checkScalar" <- function(x, isType = "numeric", ...)
-{
- # check inputs
- if (!is.character(isType))
- {
- stop("isType must be an object of class character")
- }
-
- # check scalar type
- if (isType == "integer")
- {
- bad <- (!isInteger(x) || length(x) > 1)
- }
- else {
- bad <- (!is(c(x), isType) || length(x) > 1)
- }
- if (bad)
- {
- # create error message
- parent <- as.character(sys.call(-1)[[1]])
- varstr <- paste(if (length(parent) > 0) paste("In function", parent, ": variable") else "", deparse(substitute(x)))
- stop(varstr, "must be scalar of class", isType)
- }
-
- # check if input is on specified interval
- if (length(list(...)) > 0)
- {
- checkRange(x, ..., varname=varstr)
- }
-
- invisible(NULL)
-}
-
-"checkVector" <- function(x, isType = "numeric", ..., length=NULL)
-{
- # check inputs
- checkScalar(isType, "character")
- if (!is.null(length))
- {
- checkScalar(length,"integer")
- }
-
- # define local functions
- "isVectorAtomic" <- function(x)
- return(is.atomic(x) & any(c(NROW(x), NCOL(x)) == 1))
-
- # check vector type
- bad <- if (isType == "integer")
- {
- !isVectorAtomic(x) || !isInteger(x)
- }
- else
- {
- !isVectorAtomic(x) || !is(c(x), isType) # wrap "x" in c() to strip dimension(s)
- }
- if (bad)
- {
- # create error message
- parent <- as.character(sys.call(-1)[[1]])
- varstr <- paste(if (length(parent) > 0) paste("In function", parent, ": variable") else "", deparse(substitute(x)))
- stop(paste(varstr, "must be vector of class", isType))
- }
- # check vector length
- if (!is.null(length) && (length(x) != length))
- {
- stop(paste(varstr, "is a vector of length", length(x), "but should be of length", length))
- }
-
- # check if input is on specified interval
- if (length(list(...)) > 0)
- {
- checkRange(x, ..., varname=varstr)
- }
-
- invisible(NULL)
-}
-
-"isInteger" <- function(x) all(is.numeric(x)) && all(round(x,0) == x)
-
-###
-# Hidden Functions
-###
-
-"checkMD5" <- function (package="gsDesign", dir)
-{
- if (missing(dir))
- dir <- .find.package(package, quiet = TRUE)
- if (!length(dir))
- return(NA)
- md5file <- file.path(dir, "MD5")
- if (!file.exists(md5file))
- return(NA)
-
- ignore <- c("MD5", "DESCRIPTION", "Meta/package.rds", "R/gsDesign.rdb", "R/gsDesign.rdx",
- "libs/i386/gsDesign.so", "libs/ppc/gsDesign.so")
-
- inlines <- readLines(md5file)
- xx <- sub("^([0-9a-fA-F]*)(.*)", "\\1", inlines)
- nmxx <- names(xx) <- sub("^[0-9a-fA-F]* [ |*](.*)", "\\1", inlines)
-
- nmxx <- nmxx[!(nmxx %in% ignore)]
-
- dot <- getwd()
- setwd(dir)
- x <- tools:::md5sum(dir(dir, recursive = TRUE))
- setwd(dot)
-
- x <- x[!(names(x) %in% ignore)]
- nmx <- names(x)
- res <- TRUE
- not.here <- !(nmxx %in% nmx)
- if (any(not.here)) {
- res <- FALSE
- cat("files", paste(nmxx[not.here], collapse = ", "),
- "are missing\n", sep = " ")
- }
- nmxx <- nmxx[!not.here]
- diff <- xx[nmxx] != x[nmxx]
- if (any(diff)) {
- res <- FALSE
- cat("files", paste(nmxx[diff], collapse = ", "), "have the wrong MD5 checksums\n",
- sep = " ")
- }
- return(res)
-}
+##################################################################################
+# Validation functionality for the gsDesign package
+#
+# Exported Functions:
+#
+# checkLengths
+# checkRange
+# checkScalar
+# checkVector
+# isInteger
+#
+# Hidden Functions:
+#
+# checkMD5
+#
+# Author(s): William Constantine, Ph.D.
+#
+# Reviewer(s): REvolution Computing 19DEC2008 v.2.0 - William Constantine, Kellie Wills
+#
+# R Version: 2.7.2
+#
+##################################################################################
+
+###
+# Exported Functions
+###
+
+"checkLengths" <- function(..., allowSingle=FALSE)
+{
+ lens <- unlist(lapply(list(...),length))
+
+ if (allowSingle)
+ {
+ lens <- lens[lens > 1]
+ }
+
+ if (length(lens) > 0 && length(unique(lens)) != 1)
+ {
+ parent <- as.character(sys.call(-1)[[1]])
+ stop(if (length(parent) > 0) paste("In function", parent, ":") else "",
+ "lengths of inputs are not all equal")
+ }
+
+ invisible(NULL)
+}
+
+"checkRange" <- function(x, interval = 0:1, inclusion = c(TRUE, TRUE), varname = deparse(substitute(x)),
+ tol=0)
+{
+ # check inputs
+ checkVector(interval, "numeric")
+ if (length(interval) != 2)
+ {
+ stop("Interval input must contain two elements")
+ }
+
+ interval <- sort(interval)
+ checkVector(inclusion, "logical")
+ inclusion <- if (length(inclusion) == 1) rep(inclusion, 2) else inclusion[1:2]
+
+ xrange <- range(x)
+ left <- ifelse(inclusion[1], xrange[1] >= interval[1] - tol, xrange[1] > interval[1] - tol)
+ right <- ifelse(inclusion[2], xrange[2] <= interval[2] + tol, xrange[2] < interval[2] + tol)
+
+ if (!(left && right))
+ {
+ stop(paste(varname, " not on interval ", if (inclusion[1]) "[" else "(", interval[1], ", ",
+ interval[2], if (inclusion[2]) "]" else ")", sep=""))
+ }
+
+ invisible(NULL)
+}
+
+"checkScalar" <- function(x, isType = "numeric", ...)
+{
+ # check inputs
+ if (!is.character(isType))
+ {
+ stop("isType must be an object of class character")
+ }
+
+ # check scalar type
+ if (isType == "integer")
+ {
+ bad <- (!isInteger(x) || length(x) > 1)
+ }
+ else {
+ bad <- (!is(c(x), isType) || length(x) > 1)
+ }
+ if (bad)
+ {
+ # create error message
+ parent <- as.character(sys.call(-1)[[1]])
+ varstr <- paste(if (length(parent) > 0) paste("In function", parent, ": variable") else "", deparse(substitute(x)))
+ stop(varstr, "must be scalar of class", isType)
+ }
+
+ # check if input is on specified interval
+ if (length(list(...)) > 0)
+ {
+ checkRange(x, ..., varname=varstr)
+ }
+
+ invisible(NULL)
+}
+
+"checkVector" <- function(x, isType = "numeric", ..., length=NULL)
+{
+ # check inputs
+ checkScalar(isType, "character")
+ if (!is.null(length))
+ {
+ checkScalar(length,"integer")
+ }
+
+ # define local functions
+ "isVectorAtomic" <- function(x)
+ return(is.atomic(x) & any(c(NROW(x), NCOL(x)) == 1))
+
+ # check vector type
+ bad <- if (isType == "integer")
+ {
+ !isVectorAtomic(x) || !isInteger(x)
+ }
+ else
+ {
+ !isVectorAtomic(x) || !is(c(x), isType) # wrap "x" in c() to strip dimension(s)
+ }
+ if (bad)
+ {
+ # create error message
+ parent <- as.character(sys.call(-1)[[1]])
+ varstr <- paste(if (length(parent) > 0) paste("In function", parent, ": variable") else "", deparse(substitute(x)))
+ stop(paste(varstr, "must be vector of class", isType))
+ }
+ # check vector length
+ if (!is.null(length) && (length(x) != length))
+ {
+ stop(paste(varstr, "is a vector of length", length(x), "but should be of length", length))
+ }
+
+ # check if input is on specified interval
+ if (length(list(...)) > 0)
+ {
+ checkRange(x, ..., varname=varstr)
+ }
+
+ invisible(NULL)
+}
+
+"isInteger" <- function(x) all(is.numeric(x)) && all(round(x,0) == x)
+
+###
+# Hidden Functions
+###
+
+"checkMD5" <- function (package="gsDesign", dir)
+{
+ if (missing(dir))
+ dir <- find.package(package, quiet = TRUE)
+ if (!length(dir))
+ return(NA)
+ md5file <- file.path(dir, "MD5")
+ if (!file.exists(md5file))
+ return(NA)
+
+ ignore <- c("MD5", "DESCRIPTION", "Meta/package.rds", "R/gsDesign.rdb", "R/gsDesign.rdx",
+ "libs/i386/gsDesign.so", "libs/ppc/gsDesign.so")
+
+ inlines <- readLines(md5file)
+ xx <- sub("^([0-9a-fA-F]*)(.*)", "\\1", inlines)
+ nmxx <- names(xx) <- sub("^[0-9a-fA-F]* [ |*](.*)", "\\1", inlines)
+
+ nmxx <- nmxx[!(nmxx %in% ignore)]
+
+ dot <- getwd()
+ setwd(dir)
+ x <- tools:::md5sum(dir(dir, recursive = TRUE))
+ setwd(dot)
+
+ x <- x[!(names(x) %in% ignore)]
+ nmx <- names(x)
+ res <- TRUE
+ not.here <- !(nmxx %in% nmx)
+ if (any(not.here)) {
+ res <- FALSE
+ cat("files", paste(nmxx[not.here], collapse = ", "),
+ "are missing\n", sep = " ")
+ }
+ nmxx <- nmxx[!not.here]
+ diff <- xx[nmxx] != x[nmxx]
+ if (any(diff)) {
+ res <- FALSE
+ cat("files", paste(nmxx[diff], collapse = ", "), "have the wrong MD5 checksums\n",
+ sep = " ")
+ }
+ return(res)
+}
+"checkMatrix" <- function(x, isType = "numeric", ..., nrows=NULL, ncols=NULL)
+{
+ # check inputs
+ checkScalar(isType, "character")
+ if (!is.null(nrows))
+ {
+ checkScalar(nrows,"integer")
+ }
+ if (!is.null(ncols))
+ {
+ checkScalar(ncols,"integer")
+ }
+
+ # define local functions
+ "isMatrixAtomic" <- function(x)
+ return(is.atomic(x) & all(c(NROW(x), NCOL(x)) > 0))
+
+ # check matrix type
+ bad <- if (isType == "integer")
+ {
+ !isMatrixAtomic(x) || !isInteger(x)
+ }
+ else
+ {
+ !isMatrixAtomic(x) || !is(c(x), isType) # wrap "x" in c() to strip dimension(s)
+ }
+ if (bad)
+ {
+ # create error message
+ parent <- as.character(sys.call(-1)[[1]])
+ varstr <- paste(if (length(parent) > 0) paste("In function", parent, ": variable") else "", deparse(substitute(x)))
+ stop(paste(varstr, "must be matrix of class", isType))
+ }
+ # check matrix dimensions
+ if (!is.null(nrows) && (NROW(x) != nrows))
+ {
+ stop(paste(varstr, "is a matrix with", NROW(x), "rows, but should have", nrows, "rows"))
+ }
+ if (!is.null(ncols) && (NCOL(x) != ncols))
+ {
+ stop(paste(varstr, "is a matrix with", NCOL(x), "columns, but should have", ncols, "columns"))
+ }
+
+ # check if input is on specified interval
+ if (length(list(...)) > 0)
+ {
+ checkRange(x, ..., varname=varstr)
+ }
+
+ invisible(NULL)
+}
More information about the Gsdesign-commits
mailing list