Sync with 2.18.0.1 on CRAN

Author: arni-magnusson

DESCRIPTION

@@ -5,7 +5,7 @@ Description: Various R programming tools for data manipulation, including:
    - combining objects ('bindData', 'cbindX', 'combine', 'interleave'),
    - character vector operations ('centerText', 'startsWith', 'trim'),
    - factor manipulation ('levels', 'reorder.factor', 'mapLevels'),
-   - obtaining information about R objects ('object.size', 'env',
+   - obtaining information about R objects ('object.size', 'elem', 'env',
      'humanReadable', 'is.what', 'll', 'keep', 'ls.funs',
      'Args','nPairs', 'nobs'),
    - manipulating MS-Excel formatted files ('read.xls',
@@ -23,31 +23,12 @@ Description: Various R programming tools for data manipulation, including:
 Depends: R (>= 2.3.0)
 SystemRequirements: perl (>= 5.10.0)
 Imports: gtools, stats, methods, utils
-Version: 2.19.0
-Date: 2020-10-09
-Authors@R: c(
-   person(
-      c("Gregory", "R."), "Warnes",
-      email = c("greg@warnes.net"),
-      role = c("aut", "cre")
-      ),
-   person(
-      "Arni", "Magnusson", 
-      email="Arni.magnusson@ices.dk", 
-      role="aut"
-      ),
-   person("Ben", "Bolker", role="ctb"),
-   person("Gregor", "Gorjanc", role="ctb"),
-   person("Gabor", "Grothendieck", role="ctb"),
-   person("Ales", "Korosec", role="ctb"),
-   person("Thomas", "Lumley", rol="ctb"), 
-   person("Don", "MacQueen", role="ctb"),
-   person("Jim", "Rogers", role="ctb"),
-   person("inoui llc", role="fnd", )
-   )
+Version: 2.18.0.1
+Date: 2017-06-05
+Author: Gregory R. Warnes, Ben Bolker, Gregor Gorjanc, Gabor
+        Grothendieck, Ales Korosec, Thomas Lumley, Don MacQueen, Arni
+        Magnusson, Jim Rogers, and others
 Maintainer: Gregory R. Warnes <greg@warnes.net>
 License: GPL-2
 NeedsCompilation: no
 Suggests: RUnit
-URL: https://github.com/r-gregmisc/gdata
-BugReports: https://github.com/r-gregmisc/gdata/issues

NAMESPACE

@@ -11,6 +11,7 @@ export(
        ConvertMedUnits,
        drop.levels,
        duplicated2,
+       elem,
        env,
        first,
        'first<-',
@@ -36,15 +37,14 @@ export(
        reorder.factor,
        resample,
        right,
-       # runPerlScript,
        sheetCount,
        sheetNames,
        startsWith,
        trim,
        trimSum,
        unmatrix,
        update.list,
-       update.data.frame,
+       #update.data.frame,
        upperTriangle,
        "upperTriangle<-",
        wideByFactor,
@@ -71,7 +71,7 @@ export(
 importFrom(stats, reorder)
 importFrom(stats, nobs)
 importFrom(gtools, mixedsort)
-importFrom(methods, is, slot, slotNames)
+importFrom(methods, is)
 importFrom(utils, data, download.file, head, read.csv, read.delim, read.table, tail, write.table)
 
 S3method(reorder, factor)
@@ -171,4 +171,4 @@ S3method(right, matrix)
 
 # update methods for list, data.frame
 S3method(update, list)
-S3method(update, data.frame)
+#S3method(update, data.frame)

R/elem.R

@@ -0,0 +1,9 @@
+# $Id: elem.R 625 2005-06-09 14:20:30Z nj7w $
+
+elem <- function(object=1, unit=c("KB","MB","bytes"), digits=0,
+                 dimensions=FALSE)
+{
+  .Deprecated("ll", package="gdata")
+  ll(pos=object, unit=unit, digits=digits, dimensions=dimensions)
+}
+

R/env.R

@@ -4,9 +4,9 @@ env <- function(unit="KB", digits=0)
   {
     object <- get(object.name, pos=pos)
     size <- try(unclass(object.size(object)), silent=TRUE)
-    if(class(size) == "try-error")
+    if(inherits(size, "try-error"))
       size <- 0
-    size
+    return(size)
   }
 
   get.environment.size <- function(pos)
@@ -15,12 +15,13 @@ env <- function(unit="KB", digits=0)
       size <- 0
     else
       size <- sum(sapply(ls(pos,all.names=TRUE), get.object.size, pos=pos))
-    size
+    return(size)
   }
 
   get.environment.nobjects <- function(pos)
   {
-    length(ls(pos, all.names=TRUE))
+    nobjects <- length(ls(pos,all.names=TRUE))
+    return(nobjects)
   }
 
   unit <- match.arg(unit, c("bytes","KB","MB"))

R/installXLSXsupport.R

@@ -1,20 +1,58 @@
+## s$Id: read.xls.R 1423 2010-02-21 17:12:30Z ggrothendieck2 $
+
 installXLSXsupport <- function(perl="perl", verbose=FALSE)
 {
+  ## determine proper path to perl executable
+  perl <- if (missing(perl))
+    findPerl(verbose = verbose)
+  else
+    findPerl(perl, verbose = verbose)
+  
+  ##
+  ## directories
+  package.dir <- find.package('gdata')
+  perl.dir <- file.path(package.dir,'perl')
+  ##
+  ##
+
+  cmd <- "install_modules.pl"
+  sc <- file.path(perl.dir, cmd)
+  
+  ##
+  ##
+
+  ##
+  ## execution command
+
+  cmd <- paste(shQuote(perl), shQuote(sc), sep=" ")
+
+  ##
 
   if(verbose)
-      message("Attempting to install Perl libraries to support XLSX (Excel 2007+) file format..")
+    {
+      cat("\n")
+      cat("Attempting to automaticall install Perl libraries to support XLSX (Excel 2007+) file format...\n")
+      cat("\n")
+    }
+
+  ##
+
+  output <- system(cmd, intern=TRUE)
 
-  output <- runPerlScript("install_modules.pl", perl=perl, verbose=verbose)
+  ##
+
+  if(verbose) cat("Results: ", output, "\n")
+
+  ##
 
   if( "XLSX" %in% xlsFormats(perl=perl, verbose=verbose) )
 	{
-		message("Perl XLSX support libraries successfully installed.")
+		cat("\nPerl XLSX support libraries successfully installed.\n\n")
 		invisible(TRUE)
 	}
   else
 	{
-	  stop("\nUnable to install Perl XLSX support libraries.\n\n")
+        	stop("\nUnable to install Perl XLSX support libraries.\n\n")
 		invisible(FALSE)                
 	}		
-  
 }

R/is.what.R

@@ -3,9 +3,9 @@ is.what <- function(object, verbose=FALSE)
   do.test <- function(test, object)
   {
     result <- try(get(test)(object), silent=TRUE)
-    if(length(result)!=1 || !is.logical(result) || is.na(result))
+    if(!is.logical(result) || length(result)!=1 || is.na(result))
       result <- NULL
-    result
+    return(result)
   }
 
   ## Get all names starting with "is."
@@ -22,5 +22,5 @@ is.what <- function(object, verbose=FALSE)
   else
     output <- names(results)[results]
 
-  output
+  return(output)
 }

R/keep.R

@@ -1,4 +1,4 @@
-keep <- function(..., list=character(), all=FALSE, sure=FALSE)
+keep <- function(..., list=character(0), all=FALSE, sure=FALSE)
 {
   if(missing(...) && missing(list))
   {
@@ -11,19 +11,13 @@ keep <- function(..., list=character(), all=FALSE, sure=FALSE)
   keep.elements <- match(list, ls(1,all.names=all))
   if(any(is.na(keep.elements)))
   {
-    warning("you tried to keep '", list[which(is.na(keep.elements))[1]],
-            "' which doesn't exist in workspace - nothing was removed")
+    warning("you tried to keep \"", list[which(is.na(keep.elements))[1]],
+            "\" which doesn't exist in workspace - nothing was removed", sep="")
     return(invisible(NULL))
   }
 
-  obj <- ls(1, all.names=all)[-keep.elements]
   if(sure)
-  {
-    rm(list=obj, pos=1)
-    invisible(obj)
-  }
+    rm(list=ls(1,all.names=all)[-keep.elements], pos=1)
   else
-  {
-    obj
-  }
+    return(ls(1,all.names=all)[-keep.elements])
 }

R/left.R

@@ -1,39 +1,38 @@
-left  <- function(x, n=6L, ...) UseMethod("left")
-right <- function(x, n=6L, ...) UseMethod("right")
+left  <- function(x, n=6L) UseMethod("left")
+right <- function(x, n=6L) UseMethod("left")
 
-.leftright <- function(
-    x, 
-    n=6L, 
-    add.col.nums = TRUE, 
-    direction = c("left", "right"), # center?
-    ...
-)
+left.data.frame <- function(x, n=6)
+{
+    stopifnot(length(n) == 1L)
+    n <- if (n < 0L)
+        max(ncol(x) + n, 0L)
+    else min(n, ncol(x))
+    x[, seq_len(n), drop = FALSE]
+}
+left.matrix <- left.data.frame
+
+
+right.data.frame <- function (x, n = 6L, ...)
 {
     stopifnot(length(n) == 1L)
-    
     ncx <- ncol(x)
-    
-    if (add.col.nums && is.null(colnames(x)))
-        colnames(x) <- paste0("[", 1:ncx, ",]")
-    
-    if (n < 0L)
-        n <- max(ncx + n, 0L)
-    else 
-        n <- min(n, ncx)
-    
-    if(direction=="left")
-        sel <- seq.int(from=1, length.out = n)
-    else # direction="right"
-        sel <- seq.int(to = ncx, length.out = n)
-    
-    x[, sel, drop = FALSE]
+    n <- if (n < 0L)
+        max(ncx + n, 0L)
+    else min(n, ncx)
+    x[, seq.int(to = ncx, length.out = n), drop = FALSE]
 }
 
-left.data.frame <- function(x, n=6L, add.col.nums=TRUE, ...)
-    .leftright(x, n=n, add.col.nums=add.col.nums, direction="left")
+right.matrix <- function (x, n = 6L, addcolnums = TRUE, ...)
+{
+    stopifnot(length(n) == 1L)
+    ncx <- ncol(x)
+    n <- if (n < 0L)
+        max(ncx + n, 0L)
+    else min(n, ncx)
+    sel <- seq.int(to = ncx, length.out = n)
+    ans <- x[, sel, drop = FALSE]
+    if (addcolnums && is.null(colnames(x)))
+        colnames(ans) <- paste0("[", sel, ",]")
+    ans
+}
 
-right.data.frame <- function(x, n=6L, add.col.nums=TRUE, ...)
-    .leftright(x, n=n, add.col.nums=add.col.nums, direction="right")
-    
-left.matrix <- left.data.frame
-right.matrix <- right.data.frame

R/ll.R

@@ -1,10 +1,11 @@
 ll <- function(pos=1, unit="KB", digits=0, dim=FALSE, sort=FALSE, class=NULL,
-               invert=FALSE, standard="SI", ...)
+               invert=FALSE, ...)
 {
   get.object.class <- function(object.name, pos)
   {
     object <- get(object.name, pos=pos)
-    class(object)[1]
+    class <- class(object)[1]
+    return(class)
   }
 
   get.object.dim <- function(object.name, pos)
@@ -16,26 +17,26 @@ ll <- function(pos=1, unit="KB", digits=0, dim=FALSE, sort=FALSE, class=NULL,
       dim <- paste(dim(object), collapse=" x ")
     else
       dim <- length(object)
-    dim
+    return(dim)
   }
 
   get.object.size <- function(object.name, pos)
   {
     object <- get(object.name, pos=pos)
     size <- try(unclass(object.size(object)), silent=TRUE)
-    if(class(size) == "try-error")
+    if(inherits(size,"try-error"))
       size <- 0
-    size
+    return(size)
   }
 
-  ## 1  Set original.rank
+  ## 1  Set unit, denominator, original.rank
+  unit <- match.arg(unit, c("bytes","KB","MB"))
+  denominator <- switch(unit, "KB"=1024, "MB"=1024^2, 1)
   original.rank <- NULL
 
   ## 2  Detect what 'pos' is like, then get class, size, dim
   if(is.character(pos))  # pos is an environment name
     pos <- match(pos, search())
-  if(isS4(pos))  # pos is an S4 object
-    pos <- sapply(slotNames(pos), slot, object=pos, simplify=FALSE)
   if(is.list(pos))  # pos is a list-like object
   {
     if(is.null(names(pos)))
@@ -62,27 +63,13 @@ ll <- function(pos=1, unit="KB", digits=0, dim=FALSE, sort=FALSE, class=NULL,
   }
   else
   {
-    class.vector <- sapply(ls(pos,...),
-                           get.object.class, 
-                           pos=pos)
-    
-    size.vector <- sapply(ls(pos,...), 
-                          get.object.size, 
-                          pos=pos)
-    
-    row.names <- names(size.vector)
-    
-    size.vector <- humanReadable(size.vector, 
-                                 units=unit, 
-                                 standard=standard, 
-                                 digits=digits)
-    
+    class.vector <- sapply(ls(pos,...), get.object.class, pos=pos)
+    size.vector <- sapply(ls(pos,...), get.object.size, pos=pos)
+    size.vector <- round(size.vector/denominator, digits)
     object.frame <- data.frame(class.vector=class.vector,
                                size.vector=size.vector,
-                               row.names=row.names)
-    
+                               row.names=names(size.vector))
     names(object.frame) <- c("Class", unit)
-    
     if(dim)
       object.frame <- cbind(object.frame,
                             Dim=sapply(ls(pos,...),get.object.dim,pos=pos))
@@ -101,5 +88,5 @@ ll <- function(pos=1, unit="KB", digits=0, dim=FALSE, sort=FALSE, class=NULL,
     object.frame <- object.frame[include,]
   }
 
-  object.frame
+  return(object.frame)
 }