Skip long tests on CRAN

Author: dipterix

NAMESPACE

@@ -15,6 +15,7 @@ S3method(min,FileArray)
 S3method(range,FileArray)
 S3method(subset,FileArray)
 S3method(sum,FileArray)
+export(apply)
 export(filearray_bind)
 export(filearray_create)
 export(filearray_load)
@@ -26,6 +27,7 @@ export(fwhich)
 export(mapreduce)
 export(typeof)
 exportClasses(FileArray)
+exportMethods(apply)
 exportMethods(mapreduce)
 exportMethods(typeof)
 importFrom(Rcpp,sourceCpp)

R/methods.R

@@ -498,70 +498,70 @@ setMethod('typeof', signature(x = "FileArray"), function(x){
 #' @param ... optional arguments to \code{FUN}
 #' @param simplify a logical indicating whether results should be simplified if possible
 #' @return See Section 'Value' in \code{\link[base]{apply}};
-#' @noRd
-# setGeneric("apply")
+#' @export
+setGeneric("apply")
 
 #' @rdname apply
-#' @noRd
-# setMethod(
-#     'apply', signature(X = "FileArray"), 
-#     function(X, MARGIN, FUN, ..., simplify = TRUE){
-#         if(!X$valid()){
-#             stop("Invalid file array")
-#         }
-#         dim <- X$dimension()
-#         
-#         FUN <- match.fun(FUN)
-#         simplify <- isTRUE(simplify)
-#         d <- dim(X)
-#         dl <- length(d)
-#         dn <- dimnames(X)
-#         ds <- seq_len(dl)
-#         if (is.character(MARGIN)) {
-#             dnn <- names(dn)
-#             if (is.null(dnn)) 
-#                 stop("'X' must have named dimnames")
-#             MARGIN <- match(MARGIN, dnn)
-#             if (anyNA(MARGIN)) 
-#                 stop("not all elements of 'MARGIN' are names of dimensions")
-#         }
-#         d.call <- d[-MARGIN]
-#         d.ans <- d[MARGIN]
-#         if (anyNA(d.call) || anyNA(d.ans)) {
-#             stop("'MARGIN' does not match dim(X)")
-#         }
-#         s.call <- ds[-MARGIN]
-#         s.ans <- ds[MARGIN]
-#         if(length(s.ans) != 1){
-#             stop("`apply` on FileArray margin size can only be 1.")
-#         }
-#         dn.call <- dn[-MARGIN]
-#         dn.ans <- dn[MARGIN]
-#         d2 <- prod(d.ans)
-#         if (d2 == 0L) {
-#             newX <- array(vector(typeof(X), 1L), 
-#                           dim = c(prod(d.call), 1L))
-#             if (length(d.call) < 2L) {
-#                 tmp <- newX[, 1]
-#             } else {
-#                 tmp <- array(newX[, 1L], d.call, dn.call)
-#             }
-#             ans <- forceAndCall(1, FUN, tmp, ...)
-#             if(is.null(ans)){
-#                 return(ans)
-#             } else if (length(d.ans) < 2L) {
-#                 return(ans[1L][-1L])
-#             } else {
-#                 return(array(ans, d.ans, dn.ans))
-#             }
-#         }
-#         
-#         tmp <- rep("", dl)
-#         tmp[[s.ans]] <- ".__i__."
-#         f <- sprintf("function(.__i__., ...){ FUN(X[%s], ...) }", paste(tmp, collapse = ","))
-#         f <- eval(parse(text = f))
-#         
-#         sapply(seq_len(d[[s.ans]]), f, ..., simplify = simplify)
-#     }
-# )
+#' @export
+setMethod(
+    'apply', signature(X = "FileArray"), 
+    function(X, MARGIN, FUN, ..., simplify = TRUE){
+        if(!X$valid()){
+            stop("Invalid file array")
+        }
+        dim <- X$dimension()
+        
+        FUN <- match.fun(FUN)
+        simplify <- isTRUE(simplify)
+        d <- dim(X)
+        dl <- length(d)
+        dn <- dimnames(X)
+        ds <- seq_len(dl)
+        if (is.character(MARGIN)) {
+            dnn <- names(dn)
+            if (is.null(dnn)) 
+                stop("'X' must have named dimnames")
+            MARGIN <- match(MARGIN, dnn)
+            if (anyNA(MARGIN)) 
+                stop("not all elements of 'MARGIN' are names of dimensions")
+        }
+        d.call <- d[-MARGIN]
+        d.ans <- d[MARGIN]
+        if (anyNA(d.call) || anyNA(d.ans)) {
+            stop("'MARGIN' does not match dim(X)")
+        }
+        s.call <- ds[-MARGIN]
+        s.ans <- ds[MARGIN]
+        if(length(s.ans) != 1){
+            stop("`apply` on FileArray margin size can only be 1.")
+        }
+        dn.call <- dn[-MARGIN]
+        dn.ans <- dn[MARGIN]
+        d2 <- prod(d.ans)
+        if (d2 == 0L) {
+            newX <- array(vector(typeof(X), 1L), 
+                          dim = c(prod(d.call), 1L))
+            if (length(d.call) < 2L) {
+                tmp <- newX[, 1]
+            } else {
+                tmp <- array(newX[, 1L], d.call, dn.call)
+            }
+            ans <- forceAndCall(1, FUN, tmp, ...)
+            if(is.null(ans)){
+                return(ans)
+            } else if (length(d.ans) < 2L) {
+                return(ans[1L][-1L])
+            } else {
+                return(array(ans, d.ans, dn.ans))
+            }
+        }
+        
+        tmp <- rep("", dl)
+        tmp[[s.ans]] <- ".__i__."
+        f <- sprintf("function(.__i__., ...){ FUN(X[%s], ...) }", paste(tmp, collapse = ","))
+        f <- eval(parse(text = f))
+        
+        sapply(seq_len(d[[s.ans]]), f, ..., simplify = simplify)
+    }
+)
 

filearray.Rproj

@@ -15,4 +15,5 @@ LaTeX: pdfLaTeX
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
+PackageCheckArgs: --as-cran
 PackageRoxygenize: rd,collate,namespace,vignette

man/apply.Rd

@@ -84,6 +84,7 @@ expect_equivalent_cplx <- function(x, y, eps = 1e-6){
 }
 
 test_that("R/C++ - Collapse", {
+    testthat::skip_on_cran()
     bsz <- get_buffer_size()
     on.exit({
         set_buffer_size(bsz)
@@ -194,6 +195,7 @@ test_that("R/C++ - Collapse", {
 })
 
 test_that("R/C++ - Float", {
+    testthat::skip_on_cran()
     bsz <- get_buffer_size()
     on.exit({
         set_buffer_size(bsz)
@@ -305,6 +307,7 @@ test_that("R/C++ - Float", {
 })
 
 test_that("R/C++ - Collapse (complex)", {
+    testthat::skip_on_cran()
     bsz <- get_buffer_size()
     on.exit({
         set_buffer_size(bsz)