Skip to content

Commit 093fec1

Browse files
dipterixdipterix
committed
Removed apply (wait for R 4.2), fixed dimnames when NULL exists
1 parent 43f98e3 commit 093fec1

6 files changed

Lines changed: 152 additions & 95 deletions

File tree

‎NAMESPACE‎

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,6 @@ S3method(min,FileArray)
1515
S3method(range,FileArray)
1616
S3method(subset,FileArray)
1717
S3method(sum,FileArray)
18-
export(apply)
1918
export(filearray_bind)
2019
export(filearray_create)
2120
export(filearray_load)
@@ -27,7 +26,6 @@ export(fwhich)
2726
export(mapreduce)
2827
export(typeof)
2928
exportClasses(FileArray)
30-
exportMethods(apply)
3129
exportMethods(mapreduce)
3230
exportMethods(typeof)
3331
importFrom(Rcpp,sourceCpp)

‎R/class_filearray.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -130,7 +130,7 @@ setRefClass(
130130
dim <- .self$.header$partition_dim
131131
stopifnot(is.list(v) || length(v) <= length(dim))
132132
for(ii in seq_along(v)){
133-
if(length(v[[ii]]) != dim[[ii]]){
133+
if(length(v[[ii]]) && length(v[[ii]]) != dim[[ii]]){
134134
stop("Dimension ", ii, " length mismatch")
135135
}
136136
}

‎R/methods.R‎

Lines changed: 64 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -498,70 +498,70 @@ setMethod('typeof', signature(x = "FileArray"), function(x){
498498
#' @param ... optional arguments to \code{FUN}
499499
#' @param simplify a logical indicating whether results should be simplified if possible
500500
#' @return See Section 'Value' in \code{\link[base]{apply}};
501-
#' @export
502-
setGeneric("apply")
501+
#' @noRd
502+
# setGeneric("apply")
503503

504504
#' @rdname apply
505-
#' @export
506-
setMethod(
507-
'apply', signature(X = "FileArray"),
508-
function(X, MARGIN, FUN, ..., simplify = TRUE){
509-
if(!X$valid()){
510-
stop("Invalid file array")
511-
}
512-
dim <- X$dimension()
513-
514-
FUN <- match.fun(FUN)
515-
simplify <- isTRUE(simplify)
516-
d <- dim(X)
517-
dl <- length(d)
518-
dn <- dimnames(X)
519-
ds <- seq_len(dl)
520-
if (is.character(MARGIN)) {
521-
dnn <- names(dn)
522-
if (is.null(dnn))
523-
stop("'X' must have named dimnames")
524-
MARGIN <- match(MARGIN, dnn)
525-
if (anyNA(MARGIN))
526-
stop("not all elements of 'MARGIN' are names of dimensions")
527-
}
528-
d.call <- d[-MARGIN]
529-
d.ans <- d[MARGIN]
530-
if (anyNA(d.call) || anyNA(d.ans)) {
531-
stop("'MARGIN' does not match dim(X)")
532-
}
533-
s.call <- ds[-MARGIN]
534-
s.ans <- ds[MARGIN]
535-
if(length(s.ans) != 1){
536-
stop("`apply` on FileArray margin size can only be 1.")
537-
}
538-
dn.call <- dn[-MARGIN]
539-
dn.ans <- dn[MARGIN]
540-
d2 <- prod(d.ans)
541-
if (d2 == 0L) {
542-
newX <- array(vector(typeof(X), 1L),
543-
dim = c(prod(d.call), 1L))
544-
if (length(d.call) < 2L) {
545-
tmp <- newX[, 1]
546-
} else {
547-
tmp <- array(newX[, 1L], d.call, dn.call)
548-
}
549-
ans <- forceAndCall(1, FUN, tmp, ...)
550-
if(is.null(ans)){
551-
return(ans)
552-
} else if (length(d.ans) < 2L) {
553-
return(ans[1L][-1L])
554-
} else {
555-
return(array(ans, d.ans, dn.ans))
556-
}
557-
}
558-
559-
tmp <- rep("", dl)
560-
tmp[[s.ans]] <- ".__i__."
561-
f <- sprintf("function(.__i__., ...){ FUN(X[%s], ...) }", paste(tmp, collapse = ","))
562-
f <- eval(parse(text = f))
563-
564-
sapply(seq_len(d[[s.ans]]), f, ..., simplify = simplify)
565-
}
566-
)
505+
#' @noRd
506+
# setMethod(
507+
# 'apply', signature(X = "FileArray"),
508+
# function(X, MARGIN, FUN, ..., simplify = TRUE){
509+
# if(!X$valid()){
510+
# stop("Invalid file array")
511+
# }
512+
# dim <- X$dimension()
513+
#
514+
# FUN <- match.fun(FUN)
515+
# simplify <- isTRUE(simplify)
516+
# d <- dim(X)
517+
# dl <- length(d)
518+
# dn <- dimnames(X)
519+
# ds <- seq_len(dl)
520+
# if (is.character(MARGIN)) {
521+
# dnn <- names(dn)
522+
# if (is.null(dnn))
523+
# stop("'X' must have named dimnames")
524+
# MARGIN <- match(MARGIN, dnn)
525+
# if (anyNA(MARGIN))
526+
# stop("not all elements of 'MARGIN' are names of dimensions")
527+
# }
528+
# d.call <- d[-MARGIN]
529+
# d.ans <- d[MARGIN]
530+
# if (anyNA(d.call) || anyNA(d.ans)) {
531+
# stop("'MARGIN' does not match dim(X)")
532+
# }
533+
# s.call <- ds[-MARGIN]
534+
# s.ans <- ds[MARGIN]
535+
# if(length(s.ans) != 1){
536+
# stop("`apply` on FileArray margin size can only be 1.")
537+
# }
538+
# dn.call <- dn[-MARGIN]
539+
# dn.ans <- dn[MARGIN]
540+
# d2 <- prod(d.ans)
541+
# if (d2 == 0L) {
542+
# newX <- array(vector(typeof(X), 1L),
543+
# dim = c(prod(d.call), 1L))
544+
# if (length(d.call) < 2L) {
545+
# tmp <- newX[, 1]
546+
# } else {
547+
# tmp <- array(newX[, 1L], d.call, dn.call)
548+
# }
549+
# ans <- forceAndCall(1, FUN, tmp, ...)
550+
# if(is.null(ans)){
551+
# return(ans)
552+
# } else if (length(d.ans) < 2L) {
553+
# return(ans[1L][-1L])
554+
# } else {
555+
# return(array(ans, d.ans, dn.ans))
556+
# }
557+
# }
558+
#
559+
# tmp <- rep("", dl)
560+
# tmp[[s.ans]] <- ".__i__."
561+
# f <- sprintf("function(.__i__., ...){ FUN(X[%s], ...) }", paste(tmp, collapse = ","))
562+
# f <- eval(parse(text = f))
563+
#
564+
# sapply(seq_len(d[[s.ans]]), f, ..., simplify = simplify)
565+
# }
566+
# )
567567

‎man/apply.Rd‎

Lines changed: 0 additions & 28 deletions
This file was deleted.

‎tests/testthat/test-collapse.R‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,10 @@
11

22
print(Sys.getenv())
33

4+
# Testing collapse is time consuming, skip if ran
5+
skip_collapse <- Sys.getenv("FILEARRAY_SKIP_COLLAPSE", unset = "") == "TRUE"
6+
testthat::skip_if(skip_collapse)
7+
48
collapse_real <- function(y, keep, transform = c("asis", "10log10", "square", "sqrt", "normalize")){
59
re <- switch (
610
transform,
@@ -408,3 +412,6 @@ test_that("R/C++ - Collapse (complex)", {
408412
}
409413

410414
})
415+
416+
417+
Sys.setenv("FILEARRAY_SKIP_COLLAPSE" = "TRUE")

‎tests/testthat/test-dimnames.R‎

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
test_that("Subset with dimnames", {
2+
x <- filearray_create(tempfile(), dimension = c(3,4,5,6))
3+
on.exit({
4+
x$delete()
5+
})
6+
y <- array(as.double(1:240), c(3,4,5,6))
7+
x[] <- y
8+
9+
dnames1 <- list(
10+
A = 1:3,
11+
B = 1:4,
12+
NULL,
13+
D = 1:6
14+
)
15+
dnames2 <- list(
16+
A = 1:3
17+
)
18+
dnames3 <- list(
19+
A = 1:3,
20+
B = 1:4,
21+
C = NULL,
22+
D = NULL
23+
)
24+
dnames4 <- list(
25+
A = 1:3,
26+
B = 1:4,
27+
C = 1:5,
28+
D = 1:6
29+
)
30+
31+
expect_error({
32+
dimnames(x) <- list(
33+
A = 1:4
34+
)
35+
})
36+
37+
dimnames(y) <- dnames1
38+
dimnames(x) <- dnames1
39+
40+
expect_identical(dimnames(x[]), dimnames(y))
41+
expect_identical(dimnames(x[1,1:2,2:3,1:4]), dimnames(y[1,1:2,2:3,1:4]))
42+
expect_identical(dimnames(x[1,1:2,2:3,1:4,drop=FALSE]),
43+
dimnames(y[1,1:2,2:3,1:4,drop=FALSE]))
44+
expect_identical(names(x[2,1,1,1]), names(y[2,1,1,1]))
45+
46+
dimnames(y) <- dnames2
47+
dimnames(x) <- dnames2
48+
49+
expect_identical(dimnames(x[]), dimnames(y))
50+
expect_identical(dimnames(x[1,1:2,2:3,1:4]), dimnames(y[1,1:2,2:3,1:4]))
51+
expect_identical(dimnames(x[1,1:2,2:3,1:4,drop=FALSE]),
52+
dimnames(y[1,1:2,2:3,1:4,drop=FALSE]))
53+
expect_identical(names(x[2,1,1,1]), names(y[2,1,1,1]))
54+
55+
dimnames(y) <- dnames3
56+
dimnames(x) <- dnames3
57+
58+
expect_identical(dimnames(x[]), dimnames(y))
59+
expect_identical(dimnames(x[1,1:2,2:3,1:4]), dimnames(y[1,1:2,2:3,1:4]))
60+
expect_identical(dimnames(x[1,1:2,2:3,1:4,drop=FALSE]),
61+
dimnames(y[1,1:2,2:3,1:4,drop=FALSE]))
62+
expect_identical(names(x[2,1,1,1]), names(y[2,1,1,1]))
63+
64+
65+
dimnames(y) <- dnames4
66+
dimnames(x) <- dnames4
67+
68+
expect_identical(dimnames(x[]), dimnames(y))
69+
expect_identical(dimnames(x[1,1:2,2:3,1:4]), dimnames(y[1,1:2,2:3,1:4]))
70+
expect_identical(dimnames(x[1,1:2,2:3,1:4,drop=FALSE]),
71+
dimnames(y[1,1:2,2:3,1:4,drop=FALSE]))
72+
expect_identical(names(x[2,1,1,1]), names(y[2,1,1,1]))
73+
74+
75+
# expand
76+
dimnames(x) <- dnames4
77+
x$expand(10)
78+
expect_equal(dimnames(x)$D, c(dnames4$D, rep(NA_integer_, 4)))
79+
80+
})

0 commit comments

Comments
 (0)