apply.R 2.25 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
# Test possible bugs involving the various apply functions.
#
# Added for pqR, 2015, Radford M. Neal.

# Check basic function, with and without extra arguments.

f1 <- function (x) sum(x)+1.23
f2 <- function (x,a) sum(x)+a

L <- list (a=3, b=c(1,7), c=c(5,2,9))

cat("\n-- lapply:\n")
print(lapply(L,f1))
print(lapply(L,f2,101.23))

cat("\n-- vapply:\n")
print(vapply(L,f1,numeric(1)))
print(vapply(L,f2,numeric(1),101.23))

cat("\n-- eapply:\n")
print(eapply(as.environment(L),f1))
print(eapply(as.environment(L),f2,101.23))

cat("\n-- apply:\n")
M <- matrix (1:12, 3, 4)
print(M)
print(apply(M,1,f1))
print(apply(M,2,f1))
print(apply(M,1,f2,101.23))
print(apply(M,2,f2,101.23))
31 32 33 34 35 36 37 38 39 40
A <- array (1:12, c(2,2,3))
print(A)
print(apply(A,1,f1))
print(apply(A,2,f1))
print(apply(A,3,f1))
print(apply(A,c(1,3),f1))
print(apply(A,1,f2,101.23))
print(apply(A,2,f2,101.23))
print(apply(A,3,f2,101.23))
print(apply(A,c(1,3),f2,101.23))
41 42 43 44 45 46 47 48 49 50 51 52 53 54

# Check that delayed warnings refer to [[1L]] and [[3L]].  (They don't
# if later calls modifiy earlier calls.)  The first set of warnings are
# the undelayed ones, followed at the end of this script or end of this
# section (depending on how it's run) by the delayed versions.

cat("\n-- checking warnings:\n")
for (w in c(1,0)) {
    options(warn=w)
    print(lapply(c(-1,2,-1),sqrt))  
    print(vapply(c(-1,2,-1),sqrt,numeric(1)))
    print(eapply(as.environment(list(a=-1,b=2,c=-1)),sqrt))
    M <- matrix(-1,3,4)
    print(apply(M,1,sqrt))
55 56
    A <- array(-1,c(2,2,2))
    print(apply(A,2,sqrt))
57
}
58
warnings()
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80

# Test that indexed value is corectly retained when the applied function
# returns a function that references it.

cat("\n-- checking function environments:\n")

fns <- lapply (11:13, function(x) function () x)
print(fns)
print(c(fns[[1]](),fns[[2]](),fns[[3]]()))

fns <- vapply (11:13, function(x) list(function () x), list (function () 0))
print(fns)
print(c(fns[[1]](),fns[[2]](),fns[[3]]()))

fns <- eapply (as.environment(list(a=11,b=12,c=13)), function(x) function () x)
print(fns)
print(c(fns[[1]](),fns[[2]](),fns[[3]]()))

fns <- apply (matrix(11:13,3,1), 1, function(x) function () x)
print(fns)
print(c(fns[[1]](),fns[[2]](),fns[[3]]()))

81 82 83 84
fns <- apply (array(1:8,c(2,2,2)), 1, function(x) function () x)
print(fns)
print(fns[[1]]())
print(fns[[2]]())