[Gsdesign-commits] r271 - pkg/gsDesign/R

[noreply at r-forge.r-project.org]

Author: keaven
Date: 2010-10-24 00:00:02 +0200 (Sun, 24 Oct 2010)
New Revision: 271

Modified:
   pkg/gsDesign/R/gsUtilities.R
Log:
Updated gsUtilities for general package speed-up (thx to Andy Liaw)

Modified: pkg/gsDesign/R/gsUtilities.R
===================================================================
--- pkg/gsDesign/R/gsUtilities.R	2010-10-23 21:59:06 UTC (rev 270)
+++ pkg/gsDesign/R/gsUtilities.R	2010-10-23 22:00:02 UTC (rev 271)
@@ -26,11 +26,7 @@
 ###
 
 "checkLengths" <- function(..., allowSingle=FALSE)
-{
-    parent <- as.character(sys.call(-1)[[1]])
-    err <- paste(if (length(parent) > 0) paste("In function", parent, ":") else "", 
-            "lengths of inputs are not all equal") 
-    
+{    
     lens <- unlist(lapply(list(...),length))
     
     if (allowSingle)
@@ -40,7 +36,9 @@
     
     if (length(lens) > 0 && length(unique(lens)) != 1)
     {
-        stop(err)        
+         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)  
@@ -81,25 +79,21 @@
         stop("isType must be an object of class character")
     }
     
-    # 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))) 
-    err <- paste(varstr, "must be scalar of class", isType) 
-    
     # check scalar type
     if (isType == "integer")
     {            
-        if (!isInteger(x) || length(x) > 1)
-        {
-          stop(err)
-        }
+        bad <- (!isInteger(x) || length(x) > 1)
     }
     else {
-        if (!eval(parse(text = paste("is.", isType, "(x)", sep = ""))) || length(x) > 1)
-        {
-          stop(err)
-        }
+        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)
@@ -122,25 +116,23 @@
     # define local functions
     "isVectorAtomic" <- function(x) 
         return(is.atomic(x) & any(c(NROW(x), NCOL(x)) == 1))
-    
-    # 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))) 
-    err <- paste(varstr, "must be vector of class", isType) 
-    
+        
     # check vector type
-    if (isType == "integer")
+    bad <- if (isType == "integer")
     {
-       if (!isVectorAtomic(x) || !isInteger(x))
-       {
-         stop(err)
-       }
+        !isVectorAtomic(x) || !isInteger(x)
     }
-    else if (!isVectorAtomic(x) || !eval(parse(text = paste("is.", isType, "(x)", sep = ""))))
+    else
     {
-        stop(err)
+        !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))
     {