[H5r-commits] r28 - R inst tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 26 21:34:44 CEST 2010
Author: extemporaneousb
Date: 2010-05-26 21:34:42 +0200 (Wed, 26 May 2010)
New Revision: 28
Modified:
R/h5R.R
inst/index.R
tests/.Rhistory
tests/testall.R
Log:
Fixed to work with higher dimension slicing.
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2010-05-26 01:58:17 UTC (rev 27)
+++ R/h5R.R 2010-05-26 19:34:42 UTC (rev 28)
@@ -146,32 +146,45 @@
stop("Index out of range.")
}
+.getExtras <- function(kall, dims) {
+ d <- match("drop", names(kall))
+ if (! is.na(d))
+ kall <- kall[-d]
+
+ j <- match("j", names(kall))
+ if (! is.na(j))
+ kall <- kall[-j]
+
+ i <- match("i", names(kall))
+ if (! is.na(i))
+ kall <- kall[-i]
+
+ kall <- kall[-(1:2)]
+
+ if (length(kall) != length(dims))
+ stop("Incorrect number of dimensions.")
+
+ mapply(function(a,b) {
+ if (is.call(a) || is.numeric(a) && !(as.character(a) == ""))
+ eval(a)
+ else
+ seq.int(1, b)
+ }, kall, dims, SIMPLIFY = FALSE)
+}
+
setMethod("[", "H5DataContainer", .internalSlice)
setMethod("[", "H5Dataset", function(x, i, j, ..., drop = TRUE) {
iMissing <- TRUE
if (! missing(i)) {
iMissing <- FALSE
.marginCheck(i, nrow(x))
- }
+ }
+
jMissing <- TRUE
if (! missing(j)) {
jMissing <- FALSE
.marginCheck(j, ncol(x))
}
-
- ## Not quite sure why this results in a strange state
- ## of both missing and !missing(.)
- extras <- tryCatch(list(...), simpleError = function(e) {
- return(list())
- })
-
- nExtra <- 0
- if (length(extras) > 0) {
- for (k in 3:(2 + length(extras))) {
- nExtra <- nExtra + 1
- .marginCheck(extras[[k-2]], dim(x)[k])
- }
- }
if (.inMemory(x)) {
## this is a copy of internal slice, if I don't do it this way
@@ -183,7 +196,7 @@
d <- .getData(x)
if (is.null(dim(x))) {
- if (! missing(j))
+ if (! jMissing)
stop("incorrect number of dimensions")
d[i]
}
@@ -192,6 +205,7 @@
}
}
else {
+ ## One dimensional dataset.
if (is.null(dim(x))) {
if (! jMissing)
stop("incorrect number of dimensions")
@@ -206,7 +220,32 @@
else
dta <- readSlab(x, 1, length(x))
}
+
+ ## > 1-D dataset.
else {
+
+ if (length(dim(x)) > 3) {
+ ## Need to call this function w/in this scope, but don't want
+ ## to absorb cost if we won't need it.
+ kall <- as.list(match.call())
+ }
+
+ extras <- tryCatch(list(...), simpleError = function(e) {
+ if (length(dim(x)) > 3) {
+ .getExtras(kall, dim(x)[-(1:2)]) # remove i,j
+ } else {
+ return(list())
+ }
+ })
+
+ nExtra <- 0
+ if (length(extras) > 0) {
+ for (k in 3:(2 + length(extras))) {
+ nExtra <- nExtra + 1
+ .marginCheck(extras[[k-2]], dim(x)[k])
+ }
+ }
+
## need to specify the range to select.
sel <- matrix(NA, nrow = length(dim(x)), ncol = 2)
lst <- list(`[`, x = quote(dta))
@@ -250,7 +289,6 @@
## aren't contiguous then I have to subselect the dta to conform
## to their selection.
dta <- eval(as.call(lst))
-
}
if (drop) drop(dta) else dta
}
Modified: inst/index.R
===================================================================
--- inst/index.R 2010-05-26 01:58:17 UTC (rev 27)
+++ inst/index.R 2010-05-26 19:34:42 UTC (rev 28)
@@ -47,6 +47,12 @@
setMethod("[", c("myExample", "index", "index", "ANY"), function(x, i, j, ..., drop = TRUE) {
if (VERBOSE) printCall(match.call(), formals(), nargs())
+
+ print(missing(...))
+ print(as.list(match.call()))
+ browser()
+ match.call()[4:nargs()+1]
+
x at x[toNumeric(i), toNumeric(j), ..., drop = drop]
})
@@ -158,3 +164,28 @@
+ dMissing <- TRUE
+ if (! missing(drop)) {
+ dMissing <- FALSE
+ }
+ ## All the complexity occurs
+
+ ### nArgs <- nargs()
+### kall <- as.list(match.call())
+### kall <- if (! dMissing) kall[-length(kall)]
+### nArgs <- if (! dMissing) nArgs - 1 else nArgs
+
+
+### if (nArgs > 3) {
+### start <- 3
+### start <- if (! iMissing) start + 1 else start
+### start <- if (! jMissing) start + 1 else start
+
+### extras <- kall[start:nArgs]
+### browser()
+### # extras <- Filter(function(x) class(x) == "call" || class(x) == "numeric", extras)
+### extras <- lapply(extras, eval)
+### } else {
+### extras <- list()
+### }
+
Modified: tests/.Rhistory
===================================================================
--- tests/.Rhistory 2010-05-26 01:58:17 UTC (rev 27)
+++ tests/.Rhistory 2010-05-26 19:34:42 UTC (rev 28)
@@ -1,150 +1,150 @@
-showMethods("[", "nonStructure")
-showMethod("[", "nonStructure")
-getMethod("[", "nonStructure")
-f = function(a, ...) list(...)
-f(a = 1, ... = 3)
-f(a = 1, ... = list(1,2))
-1
-ds4[1, c(1,3,5)]
+ds3[1,1,,drop=TRUE]
+id3[1,1,,drop=TRUE]
+id3[1,1,,drop=TRUE]
+ds3[1,1,,drop=TRUE]
+ds3[1,1,,drop=TRUE]
+n
+extras
+start
+nArgs
nargs()
-formals()
-match.call()
-ext
-sel[,1]
-i
-j
-sel[,1] - ext + 1
+kall
+nArgs
Q
-ds4[1, c(2,3,5)]
+?nargs
+ds3
+ds3[]
+ds3[]
+ds3[]
+ds3[]
+TH(action="print")
+TH(action="print")
+source("/home/NANOFLUIDICS/jbullard/projects/software/R/common/h5r/tests/testall.R")
+source("/home/NANOFLUIDICS/jbullard/projects/software/R/common/h5r/tests/testall.R")
+source("/home/NANOFLUIDICS/jbullard/projects/software/R/common/h5r/tests/testall.R")
+ds9[]
+x = ds9[]
+ds9
+ds9[,,,,,]
+x =ds9[,,,,,]
+x =ds9[,,,,,,,,,]
+x =ds9[,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,]
+x =ds3[,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,]
+x
+ds3[,,]
+ds3[,,,,,]
+id3[,,,,,]
+id3[1,1,]
+ds9[1,1,]
+x = ds9[1,1,]
+x = ds9[1,,]
+x = ds9[,,]
+x = ds9[,,,1:2,]
+x = ds9[,,,1:2,]
+class(quote(x))
+as.character(quote(x))
+x = ds9[,,,1:2,]
+x = ds9[,,,1:2,]
+x = ds9[,,,1:2]
+x = ds9[,1:2]
+x
+x
+dim(x)
+x = ds9[,1:2,,1]
+traceback()
+x = ds9[,1:2,,1]
n
-ext
-length(i)
-length(j)
-extras
-ext
-sapply(list(i, j, extras), length)
-dta
+names(kall)
+j
i
-j
-"["(dta, i, j, ... = ..., drop = drop)
-"["(dta, i, j-1, ... = ..., drop = drop)
-"["(dta, i, j-1, ... = list(), drop = drop)
-...
-list(...)
-"["(dta, i, j-1, drop = drop)
-"["(dta, i, j-1, drop = drop)
-"["(dta, i, j-1, ... = NA, drop = drop)
-"["(dta, i, j-1, ... = , drop = drop)
-"["(dta, i, j-1, ... , drop = drop)
-class(...)
-class(list(...))
-is.missing(...)
-missing(...)
+d
+kall
+kall
Q
-ds4[1, c(2,3,5)]
+x = ds9[,1:2,,1]
+x
+dim(ds9[,1:2,,1])
+x = ds9[,1:2,,1]
n
+kall
n
-lst
-match.call()
-diff(sel[2,])
-length(j)
-lst
-lst
-lst
+kall
+names(kall)
+length(kall)
+kall
+as.list(kall)
Q
-ds4[1, c(2,3,5)]
+x = ds9[,1:2,,1]
n
-lst
+kall
+names(kall)
+j
+i
+d
+kall
+Q
+x = ds9[,1:2,,1]
n
+kall
n
-dta
-match.call()
-as.list(match.call())
-match.call()
-as.list(match.call())
-as.call(list("[", x = substitute(dta), i = lst$i, j = lst$j))
-list("[", x = substitute(dta), i = lst$i, j = lst$j)
-list("[", x = deparse(dta), i = lst$i, j = lst$j)
-list("[", x = quote(dta), i = lst$i, j = lst$j)
-as.call(list("[", x = quote(dta), i = lst$i, j = lst$j))
-eval(as.call(list("[", x = quote(dta), i = lst$i, j = lst$j)))
-eval(as.call(list(`[`, x = quote(dta), i = lst$i, j = lst$j)))
-ds4[1, c(2,3,5)]
-Q
+x = ds9[,1:2,,1]
c
-TH(action="print")
-TH(action="print")
-TH(action="print")
-TH(action="print")
-TH(action="print")
-ds3[,,]
-ds3[,1,]
-?debug
-trace("[", browser)
-trace("[", browser, signature = "H5Dataset")
-untrace("[")
-trace("[", browser, signature = "H5Dataset")
-ds3[,1,]
+dim(x)
+x = ds9[,1:2,,1,drop=FALSE]
+c
+dim(x)
+all(id9[c(7, 10), c(3, 4), , , ] == ds9[ c(7, 10), c(3, 4), , , ])
+ds9[ c(7, 10), c(3, 4), , , ]
+dim(ds9[ c(7, 10), c(3, 4), , , ])
+dim(ds9[ c(7, 10), c(3, 4), , , ])
n
-n
-eval(as.call(list(`[`, x = quote(dta), i = lst$i, j = lst$j, lst[[3]])))
-lst[[3]]
-lst
Q
-ds3[]
-n
-lst
-as.call(list(`[`, x = quote(dta), i = lst$i, j = lst$j, lst[[3]][[1]])
-)
-eval(as.call(list(`[`, x = quote(dta), i = lst$i, j = lst$j, lst[[3]][[1]])))
+dim(ds9[ c(7, 10), c(3, 4), , , ])
+TH(action='print')
+TH(action='print')
+ )
+id9[ , , , 1:2, 1:2 ]
+dim(id9[ , , , 1:2, 1:2 ])
+dim(ds9[ , , , 1:2, 1:2])
+dim(ds9[ , , , 1:2, 1:2])
+dim(ds9[ , , , 1:2, 1:2])
+dim(ds9[ , , , 1:2, 1:2])
+TH(action='print')
+ds9[ , , 2:1, 2:1, , ])
+ds9[ , , 2:1, 2:1, , ]
+traceback()
+ds9[ , , 2:1, 2:1, , ]
+extras
Q
-TH(action="print")
-ds3[]
+ds9[ , , 2:1, 2:1, , ]
n
-n
-lst
-lst[[3]]
-lst[-(1:2)]
-lst
-dta
-lst[-(1:2)
-]
+kall
+dims
+dims
+kall
+sapply(kall, class)
Q
-TH(action="print")
- ds3[]
+ds9[ , , , 2:1, 2:1 ]
+kall
+dims
+Q
+ds9[ , , 1:2, 1:2, ])
+ds9[ , , 1:2, 1:2, ]
c
- ds3[,1]
c
- ds3[,,1]
+dim(ds9[ , , 1:2, 1:2, ])
c
-TH(action="print")
-ds3[,,]
-ds3
-all(id3[1,,3,drop=TRUE] == ds3[1,,3,drop=TRUE])
-id3[1,,3]
-ds3[1,,3]
-trace("[", browser, signature = "H5Dataset")
-ds3[1,,3,drop=TRUE]
-n
-sel
-lst
-n
-n
-dta
-lst
-eval(as.call(lst))
-dim(dta)
-dta[1,1:7,3]
-diff(sel[1,])
-diff(sel[3,])
-sel
-Q
-TH(action="print")
-TH(action="print")
-ds4M[1, c(1,3,5)]
-ds4[1, c(2,3,5)]
-TH(action="print")
-TH(action="print")
+c
+TH(action='print')
+id9[1,1,1,1,1, drop=FALSE]
+ds9[1,1,1,1,1,drop=FALSE]
+TH(action='print')
+source("/home/NANOFLUIDICS/jbullard/projects/software/R/common/h5r/tests/testall.R")
+listH5Contents()
listH5Contents(f)
-listH5Contents(f)
-1
+length(listH5Contents(f))
+TH(action='print')
+TH(action='print')
+listH5Contents(g)
+length(listH5Contents(g))
+TH(action='print')
Modified: tests/testall.R
===================================================================
--- tests/testall.R 2010-05-26 01:58:17 UTC (rev 27)
+++ tests/testall.R 2010-05-26 19:34:42 UTC (rev 28)
@@ -36,7 +36,7 @@
tm <- system.time({
b <- tryCatch(test, simpleError = function(e) {
return(FALSE)
- })
+ }, simpleWarning = function(e) return(FALSE))
})
tests[[nm]] <<- list("result" = b, "time" = tm)
},
@@ -109,8 +109,15 @@
TH("3d consistency, slabbed", all(id3[,,] == ds3[,,]) &
all(id3[,1,,drop=TRUE] == ds3[,1,,drop=TRUE]) &
all(id3[1,1,,drop=TRUE] == ds3[1,1,,drop=TRUE]) &
- all(id3[1,,3,drop=TRUE] == ds3[1,,3,drop=TRUE]))
+ all(id3[1,,3,drop=TRUE] == ds3[1,,3,drop=TRUE]) &
+ all(id3[1,,1:3,drop=TRUE] == ds3[1,,1:3,drop=TRUE]))
+TH("3d consistency, contiguity",
+ all(id3[,2:1,] == ds3[,2:1,]) &
+ all(id3[,1,seq(1,9,by=4)] == ds3[,1,seq(1,9,by=4)]) &
+ all(id3[3:1,,] == ds3[3:1,,]))
+
+
TH("3d consistency, memory", all(id3[,,] == ds3M[,,]) &
all(id3[,1,,drop=TRUE] == ds3M[,1,,drop=TRUE]) &
all(id3[1,1,,drop=TRUE] == ds3M[1,1,,drop=TRUE]) &
@@ -142,25 +149,30 @@
ds5 <- getH5Dataset(g, "ds_5")
ds5M <- ds5[]
-all(ds5[10:1, ] == ds5M[ 10:1, ])
-all(ds5[10:1, 2] == ds5M[ 10:1, 2])
-all(ds5[seq(1, 10, by = 3), 2] == ds5M[ seq(1, 10, by = 3), 2])
+TH("ds5 contiguity",
+ all(ds5[10:1, ] == ds5M[ 10:1, ]) &&
+ all(ds5[10:1, 2] == ds5M[ 10:1, 2]) &&
+ all(ds5[seq(1, 10, by = 3), 2] == ds5M[ seq(1, 10, by = 3), 2]))
-
## 5-d object
ds9M <- getH5Dataset(g, "ds_9", inMemory = T)
-ds9 <- getH5Dataset(g, "ds_9", inMemory = F)
+ds9 <- getH5Dataset(g, "ds_9", inMemory = F)
+id9 <- ds9M[,,,,]
-id9 <- ds9M[,,,,]
-all(id9[] == ds9M[,,,,])
-all(id9[] == ds9[])
+TH("5-d 0", all(id9[] == ds9M[,,,,]) && all(id9[] == ds9[]))
-all(id9[c(7, 10), c(3, 4), , , ] == ds9[ c(7, 10), c(3, 4), , , ])
-all(id9[c(7, 10), c(3, 4), c(1, 5), , ] == ds9[ c(7, 10), c(3, 4), c(1, 5), , ])
-dim(id9[c(7, 10), c(3, 4), 1:5, , ] == ds9[ c(7, 10), c(3, 4), 1:5, , ])
-all(dim(id9[c(7, 10), c(3, 4), , , ]) == dim(ds9[ c(7, 10), c(3, 4), , , ]))
-all(dim(id9[c(10, 7), 10:1, , , ]) == dim(ds9[ c(10, 7), 10:1, , , ]))
+TH("5-d",
+ all(id9[c(7, 10), c(3, 4), , , ] == ds9[ c(7, 10), c(3, 4), , , ]) &&
+ all(id9[c(7, 10), c(3, 4), c(1, 5), , ] == ds9[ c(7, 10), c(3, 4), c(1, 5), , ]) &&
+ all(id9[c(7, 10), c(3, 4), 1:5, , ] == ds9[ c(7, 10), c(3, 4), 1:5, , ]) &&
+ all(id9[c(7, 10), c(3, 4), , , ] == ds9[ c(7, 10), c(3, 4), , , ]) &&
+ all(id9[c(10, 7), 10:1, , , ] == ds9[ c(10, 7), 10:1, , , ]) &&
+ all(id9[, , 1:2, 1:2, ] == ds9[ , , 1:2, 1:2, ]) &&
+ all(id9[, , 2:1, 2:1, ] == ds9[ , , 2:1, 2:1, ]) &&
+ all(id9[ , , , 1:2, 1:2 ] == ds9[ , , , 1:2, 1:2]) &&
+ all(id9[1,1,1,1,1] == ds9[1,1,1,1,1]))
+
##
## More in-depth testing of slicing.
##
@@ -210,13 +222,12 @@
all.equal(a,b)
})
-
TH("list attributes, file", {
- length(listH5Contents(f)) == 14
+ length(listH5Contents(f)) == 15
})
TH("list attributes, group", {
- length(listH5Contents(g)) == 11
+ length(listH5Contents(g)) == 12
})
ds8 <- getH5Dataset(g, "ds_8", inMemory = FALSE)
More information about the H5r-commits
mailing list