[H5r-commits] r47 - R src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 26 02:42:22 CEST 2011
Author: extemporaneousb
Date: 2011-04-26 02:42:21 +0200 (Tue, 26 Apr 2011)
New Revision: 47
Added:
tests/testread.R
Modified:
R/h5R.R
src/h5_wrap.c
tests/testReadPoints.R
tests/testwrite.R
Log:
added attribute writing support.
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2011-04-22 23:56:39 UTC (rev 46)
+++ R/h5R.R 2011-04-26 00:42:21 UTC (rev 47)
@@ -44,7 +44,17 @@
setGeneric("writeH5Data", function(h5Obj, ...) standardGeneric("writeH5Data"))
setGeneric("readH5Data", function(h5Obj, ...) standardGeneric("readH5Data"))
setGeneric("deleteH5Obj", function(h5Obj, h5ObjName, ...) standardGeneric("deleteH5Obj"))
+setGeneric("deleteH5Attribute", function(h5Obj, attrName, ...) standardGeneric("deleteH5Attribute"))
+## ##############################################################################
+##
+## C-helper
+##
+## ##############################################################################
+.myCall <- function(nm, ...) {
+ .Call(nm, ..., PACKAGE = 'h5r')
+}
+
H5File <- function(fileName, mode = 'r') {
new("H5File", fileName, mode)
}
@@ -81,17 +91,17 @@
}
setMethod("getH5Group", c("H5Container", "character"), function(h5Obj, groupName) {
- if (is.null(x <- .Call("h5R_get_group", .ePtr(h5Obj), groupName, PACKAGE = 'h5r')))
+ if (is.null(x <- .myCall("h5R_get_group", .ePtr(h5Obj), groupName)))
stop(paste("Group:", groupName, "cannot be opened."))
.H5Group(x, groupName)
})
setMethod("getH5Dim", "H5DataContainer", function(h5Obj) {
- .Call('h5R_get_dims', .ePtr(h5Obj), PACKAGE = 'h5r')
+ .myCall('h5R_get_dims', .ePtr(h5Obj))
})
setMethod("getH5Type", "H5DataContainer", function(h5Obj) {
- .Call("h5R_get_type", .ePtr(h5Obj), PACKAGE = 'h5r')
+ .myCall("h5R_get_type", .ePtr(h5Obj))
})
setMethod("initialize", c("H5File"), function(.Object, fileName, mode = c('r', 'w')) {
@@ -103,13 +113,13 @@
mode <- match.arg(mode)
if (! file.exists(fileName) && mode == 'w') {
- .Call("h5R_create", fileName, package = "h5R")
+ .myCall("h5R_create", fileName, package = "h5R")
}
if (! file.exists(fileName)) {
stop(paste("Unable to open file:", fileName, "does not exist."))
}
- x <- .Call("h5R_open", fileName, if(mode == 'r') as.integer(0) else as.integer(1), package = "h5R")
+ x <- .myCall("h5R_open", fileName, if(mode == 'r') as.integer(0) else as.integer(1), package = "h5R")
if (is.null(x)) {
stop(paste("Problem opening file:", fileName))
@@ -136,7 +146,7 @@
}
setMethod("getH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, inMemory = FALSE) {
- if (is.null(x <- .Call("h5R_get_dataset", .ePtr(h5Obj), datasetName, PACKAGE = 'h5r'))) {
+ if (is.null(x <- .myCall("h5R_get_dataset", .ePtr(h5Obj), datasetName))) {
stop(paste("Dataset:", datasetName, "cannot be opened."))
}
o <- new("H5Dataset")
@@ -145,7 +155,7 @@
})
setMethod("getH5Attribute", c("H5Obj", "character"), function(h5Obj, attrName) {
- if (is.null(x <- .Call("h5R_get_attr", .ePtr(h5Obj), attrName, PACKAGE = 'h5r'))) {
+ if (is.null(x <- .myCall("h5R_get_attr", .ePtr(h5Obj), attrName))) {
stop(paste("Attribute:", attrName, "cannot be opened."))
}
o <- new("H5Attribute")
@@ -157,11 +167,11 @@
## Writing.
##
.flush <- function(h5Obj) {
- .Call("h5R_flush", .ePtr(h5Obj))
+ .myCall("h5R_flush", .ePtr(h5Obj))
}
setMethod("writeH5Data", c("H5Dataset"), function(h5Obj, data, offsets, extents) {
- .Call("h5R_write_slab", .ePtr(h5Obj), as.integer(offsets), as.integer(extents), data)
+ .myCall("h5R_write_slab", .ePtr(h5Obj), as.integer(offsets) - 1, as.integer(extents), data)
})
setMethod("createH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, data,
@@ -208,11 +218,11 @@
if (mChnk)
chunkSizes <- rep(4096, length(dims))
- .Call("h5R_create_dataset", .ePtr(h5Obj), datasetName, iType, dims, as.integer(chunkSizes))
+ .myCall("h5R_create_dataset", .ePtr(h5Obj), datasetName, iType, dims, as.integer(chunkSizes))
if (! mData) {
writeH5Data(getH5Dataset(h5Obj, datasetName), data,
- as.integer(rep(0L, length(dims))),
+ as.integer(rep(1L, length(dims))),
as.integer(dims))
}
.flush(h5Obj)
@@ -230,7 +240,7 @@
}
}
- if (.Call("h5R_create_group", .ePtr(h5Obj), groupName, PACKAGE = 'h5r') == 0) {
+ if (.myCall("h5R_create_group", .ePtr(h5Obj), groupName) == 0) {
.flush(h5Obj)
return(getH5Group(h5Obj, groupName))
} else {
@@ -238,15 +248,41 @@
}
})
-setMethod("createH5Attribute", c("H5Obj"), function(h5Obj, attrName, attrValue) {
- stop("Not implemented yet.")
+setMethod("createH5Attribute", c("H5Obj"), function(h5Obj, attrName, attrValue, overwrite = TRUE) {
+ if (h5AttributeExists(h5Obj, attrName)) {
+ if (overwrite) {
+ deleteH5Attribute(h5Obj, attrName)
+ .flush(h5Obj)
+ } else {
+ stop("Attribute exists, delete first, or specify overwrite.")
+ }
+ }
+ dType <- as.integer(match(storage.mode(attrValue), .h5Types) - 1)
+ if (is.null(dim(attrValue))) {
+ nr <- length(attrValue)
+ nc <- 1
+ } else {
+ if (length(dim(attrValue)) > 2) {
+ stop("Don't support greater than 2-d attributes")
+ }
+ nr <- nrow(attrValue)
+ nc <- ncol(attrValue)
+ }
+ .Call("h5R_create_attribute", .ePtr(h5Obj), as.character(attrName), as.integer(dType),
+ as.integer(c(nr, nc)))
+ .Call("h5R_write_attribute", .ePtr(getH5Attribute(h5Obj, attrName)), attrValue)
+ .flush(h5Obj)
})
setMethod("deleteH5Obj", c("H5Container"), function(h5Obj, h5ObjName) {
- .Call("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName))
+ .myCall("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName))
.flush(h5Obj)
})
+setMethod("deleteH5Attribute", c("H5Obj"), function(h5Obj, attrName) {
+ .myCall("h5R_delete_attribute", .ePtr(h5Obj), as.character(attrName))
+})
+
##
## The whole slicing infrastructure.
##
@@ -337,12 +373,12 @@
if (! jMissing)
stop("incorrect number of dimensions")
if (! iMissing) {
- dta <- readSlab(x, min(i), max(i) - min(i) + 1)
-
- ## contiguity
- if (any(diff(i) != 1)) {
- dta <- dta[i - min(i) + 1]
- }
+ ## dta <- readSlab(x, min(i), max(i) - min(i) + 1)
+ ## ## contiguity
+ ## if (any(diff(i) != 1)) {
+ ## dta <- dta[i - min(i) + 1]
+ ## }
+ dta <- readPoints(x, i)
}
else
dta <- readSlab(x, 1, length(x))
@@ -451,14 +487,14 @@
}
read1DSlabs <- function(h5Dataset, offsets, dims) {
- .Call("h5R_read_1d_slabs", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
+ .myCall("h5R_read_1d_slabs", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
}
readSlab <- function(h5Dataset, offsets, dims) {
if (! all((offsets + dims - 1) <= dim(h5Dataset)))
stop("error invalid slice specification in readSlab.")
- d <- .Call("h5R_read_slab", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
+ d <- .myCall("h5R_read_slab", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
dim(d) <- rev(dims)
if (! is.null(dim(h5Dataset))) aperm(d) else d
@@ -469,18 +505,17 @@
nr <- length(idxs)
nc <- 1
} else {
- nr <- nrow(idxs)
- nc <- ncol(idxs)
+ stop("readPoints doesn't work on higher dimensional data.")
}
- .Call("h5R_read_points", .ePtr(h5Dataset), as.integer(idxs), as.integer(nr), as.integer(nc))
+ .myCall("h5R_read_points", .ePtr(h5Dataset), as.integer(idxs - 1), as.integer(nr), as.integer(nc))
}
setMethod("readH5Data", "H5Dataset", function(h5Obj) {
- .Call('h5R_read_dataset', .ePtr(h5Obj), PACKAGE = 'h5r')
+ .myCall('h5R_read_dataset', .ePtr(h5Obj))
})
setMethod("readH5Data", "H5Attribute", function(h5Obj) {
- .Call('h5R_read_attr', .ePtr(h5Obj), PACKAGE = 'h5r')
+ .myCall('h5R_read_attr', .ePtr(h5Obj))
})
setMethod("show", "H5Obj", function(object) {
@@ -523,8 +558,8 @@
##
## construct a list of elements in the file.
-.listH5Contents <- function(h5Obj) .Call("h5R_list_contents", .ePtr(h5Obj))
-.listH5Attributes <- function(h5Obj) .Call("h5R_list_attributes", .ePtr(h5Obj))
+.listH5Contents <- function(h5Obj) .myCall("h5R_list_contents", .ePtr(h5Obj))
+.listH5Attributes <- function(h5Obj) .myCall("h5R_list_attributes", .ePtr(h5Obj))
listH5Contents <- function(h5Obj) {
contents <- .listH5Contents(h5Obj)
@@ -554,15 +589,15 @@
}
h5GroupExists <- function(h5Obj, name) {
- .Call("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
}
h5DatasetExists <- function(h5Obj, name) {
- .Call("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
}
h5AttributeExists <- function(h5Obj, name) {
- .Call("h5R_attribute_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_attribute_exists", .ePtr(h5Obj), name) == 1
}
Modified: src/h5_wrap.c
===================================================================
--- src/h5_wrap.c 2011-04-22 23:56:39 UTC (rev 46)
+++ src/h5_wrap.c 2011-04-26 00:42:21 UTC (rev 47)
@@ -9,6 +9,8 @@
#define DEBUG 0
#define HID(argname) (((h5_holder*) R_ExternalPtrAddr(argname))->id)
#define NM(argname) (CHAR(STRING_ELT(argname, 0)))
+#define SUCCESS (ScalarInteger(0))
+#define FAILURE (ScalarInteger(1))
typedef struct h5_holder {
int is_file;
@@ -17,33 +19,28 @@
void h5R_finalizer(SEXP h5_obj) {
h5_holder* h = (h5_holder*) R_ExternalPtrAddr(h5_obj);
-
if (! h) return;
if (h->is_file == 1) {
H5Fflush(HID(h5_obj), H5F_SCOPE_GLOBAL);
H5Fclose(HID(h5_obj));
}
-
Free(h);
}
SEXP h5R_flush(SEXP h5_file) {
H5Fflush(HID(h5_file), H5F_SCOPE_GLOBAL);
- return ScalarInteger(0);
+ return SUCCESS;
}
SEXP _h5R_make_holder (hid_t id, int is_file) {
if (id < 0) {
return R_NilValue;
}
-
h5_holder* holder = (h5_holder*) Calloc(1, h5_holder);
holder->id = id;
holder->is_file = is_file;
-
SEXP e_ptr = R_MakeExternalPtr(holder, install("hd5_handle"), R_NilValue);
R_RegisterCFinalizerEx(e_ptr, h5R_finalizer, TRUE);
-
return e_ptr;
}
@@ -63,8 +60,7 @@
SEXP h5R_create_group(SEXP h5_obj, SEXP group_name) {
hid_t group = H5Gcreate(HID(h5_obj), NM(group_name), H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT);
H5Gclose(group);
-
- return ScalarInteger(0);
+ return SUCCESS;
}
SEXP h5R_get_dataset(SEXP h5_obj, SEXP dataset_name) {
@@ -89,7 +85,6 @@
default:
error("Unkown object in %s.\n", __func__);
}
-
PROTECT(dtype = ScalarInteger(H5Tget_class(cls_id)));
H5Tclose(cls_id);
UNPROTECT(1);
@@ -322,7 +317,7 @@
Free(current_dims);
Free(chunk_lens);
- return ScalarInteger(0);
+ return SUCCESS;
}
SEXP h5R_write_slab(SEXP h5_dataset, SEXP _offsets, SEXP _counts, SEXP data) {
@@ -364,7 +359,7 @@
H5Tset_size (memtype, H5T_VARIABLE);
tmp = (char**) Calloc(length(data), char*);
for (i = 0; i < length(data); i++)
- tmp[i] = CHAR(STRING_ELT(data, i));
+ tmp[i] = (char*) CHAR(STRING_ELT(data, i));
_data = (void*) tmp;
break;
default:
@@ -373,8 +368,7 @@
if (__ERROR__ == 0) {
H5Dwrite(HID(h5_dataset), memtype, memspace, space, H5P_DEFAULT, _data);
- if (memtype_int == H5T_STRING)
- Free(tmp);
+ if (memtype_int == H5T_STRING) Free(tmp);
}
/** clean up. **/
@@ -493,9 +487,9 @@
SEXP h5R_read_points(SEXP h5_dataset, SEXP _points, SEXP _nr, SEXP _nc) {
int __ERROR__ = 0;
- SEXP dta = R_NilValue;
- hid_t space = -1, memspace = -1, memtype = -1;
- void* buf = NULL;
+ SEXP dta = R_NilValue;
+ hid_t space = -1, memspace = -1, memtype = -1;
+ void* buf = NULL;
int i;
int nr = INTEGER(_nr)[0];
@@ -503,13 +497,13 @@
/** I'm surprised I have to do this, but it seems to be necessary. **/
hsize_t* points = (hsize_t*) Calloc(nr*nc, hsize_t);
- for (i = 0; i < nr*nc; i++) points[i] = INTEGER(_points)[i];
+ for (i = 0; i < nr*nc; i++) points[i] = INTEGER(_points)[i];
- hsize_t nrp = nr;
+ hsize_t hnr = nr;
space = _h5R_get_space(h5_dataset);
H5Sselect_elements(space, H5S_SELECT_SET, nr, points);
- memspace = H5Screate_simple(nc, &nrp, NULL);
+ memspace = H5Screate_simple(nc, &hnr, NULL);
switch (INTEGER(h5R_get_type(h5_dataset))[0]) {
case H5T_INTEGER:
@@ -530,46 +524,117 @@
default:
__ERROR__ = 1;
}
-
if (__ERROR__ == 0) {
H5Dread(HID(h5_dataset), memtype, memspace, space, H5P_DEFAULT, buf);
/** There requires a little more with strings. **/
- /* if (H5T_STRING == INTEGER(h5R_get_type(h5_dataset))[0]) { */
- /* PROTECT(dta = allocVector(STRSXP, v)); */
- /* for (i = 0; i < v; i++) */
- /* if (((char **) buf)[i]) { */
- /* SET_STRING_ELT(dta, i, mkChar( ((char **) buf)[i] )); */
- /* } */
-
- /* H5Dvlen_reclaim (memtype, memspace, H5P_DEFAULT, buf); */
-
- /* H5Tclose(memtype); */
- /* Free(buf); */
- /* } */
+ if (H5T_STRING == INTEGER(h5R_get_type(h5_dataset))[0]) {
+ PROTECT(dta = allocVector(STRSXP, nr));
+ for (i = 0; i < nr; i++)
+ if (((char **) buf)[i]) {
+ SET_STRING_ELT(dta, i, mkChar( ((char **) buf)[i] ));
+ }
+ H5Dvlen_reclaim (memtype, memspace, H5P_DEFAULT, buf);
+ H5Tclose(memtype);
+ Free(buf);
+ }
}
/** clean up. **/
Free(points);
H5Sclose(memspace);
H5Sclose(space);
-
UNPROTECT(1);
if (__ERROR__ == 1) {
error("Unsupported class in %s\n", __func__);
}
-
-
return dta;
}
SEXP h5R_delete_object(SEXP h5_obj, SEXP name) {
H5Ldelete(HID(h5_obj), NM(name), H5P_DEFAULT);
- return R_NilValue;
+ return SUCCESS;
}
+
+SEXP h5R_delete_attribute(SEXP h5_obj, SEXP name) {
+ H5Adelete(HID(h5_obj), NM(name));
+ return SUCCESS;
+}
+
+SEXP h5R_create_attribute(SEXP h5_obj, SEXP name, SEXP h5_type, SEXP dims) {
+ int i;
+ hsize_t* current_dims = (hsize_t*) Calloc(length(dims), hsize_t);
+ hsize_t* max_dims = (hsize_t*) Calloc(length(dims), hsize_t);
+
+ for (i = 0; i < length(dims); i++) {
+ current_dims[i] = INTEGER(dims)[i];
+ max_dims[i] = H5S_UNLIMITED;
+ }
+
+ hid_t memtype = -1;
+
+ switch (INTEGER(h5_type)[0]) {
+ case H5T_INTEGER:
+ memtype = H5T_NATIVE_INT;
+ break;
+ case H5T_FLOAT:
+ memtype = H5T_NATIVE_DOUBLE;
+ break;
+ case H5T_STRING:
+ memtype = H5Tcopy (H5T_C_S1);
+ H5Tset_size (memtype, H5T_VARIABLE);
+ break;
+ default:
+ error("Unsupported class in %s.\n", __func__);
+ }
+
+ hid_t dataspace = H5Screate_simple(length(dims), current_dims, max_dims);
+ hid_t attribute = H5Acreate(HID(h5_obj), NM(name), memtype,
+ dataspace, H5P_DEFAULT, H5P_DEFAULT);
+
+ H5Aclose(attribute);
+ H5Sclose(dataspace);
+ Free(max_dims);
+ Free(current_dims);
+ return SUCCESS;
+}
+
+SEXP h5R_write_attribute(SEXP h5_attr, SEXP data) {
+ hid_t memtype = -1;
+ void* buf = NULL;
+ char** tmp = NULL;
+ int i;
+
+ switch (INTEGER(h5R_get_type(h5_attr))[0]) {
+ case H5T_INTEGER:
+ buf = INTEGER(data);
+ memtype = H5T_NATIVE_INT;
+ break;
+ case H5T_FLOAT:
+ buf = REAL(data);
+ memtype = H5T_NATIVE_DOUBLE;
+ break;
+ case H5T_STRING:
+ memtype = H5Tcopy (H5T_C_S1);
+ H5Tset_size (memtype, H5T_VARIABLE);
+ tmp = (char**) Calloc(length(data), char*);
+ for (i = 0; i < length(data); i++)
+ tmp[i] = (char*) CHAR(STRING_ELT(data, i));
+ buf = (void*) tmp;
+ break;
+ default:
+ error("Unsupported class in %s.\n", __func__);
+ }
+ H5Awrite(HID(h5_attr), memtype, buf);
+
+ // XXX FREE ! ! !
+
+ return SUCCESS;
+}
+
SEXP h5R_read_attr(SEXP h5_attr) {
SEXP dta = R_NilValue;
hid_t memtype = -1;
Modified: tests/testReadPoints.R
===================================================================
--- tests/testReadPoints.R 2011-04-22 23:56:39 UTC (rev 46)
+++ tests/testReadPoints.R 2011-04-26 00:42:21 UTC (rev 47)
@@ -1,17 +1,24 @@
require(h5r)
-require(h5r)
h5 <- H5File("test.h5", 'w')
-d <- createH5Dataset(h5, "jim", c('jime ', 'joe', 'mikey'))
-d <- createH5Dataset(h5, "dd", rnorm(1000000))
+createH5Attribute(h5, "e", 10:1)
+createH5Attribute(h5, "d", c("jome?", "jeosfmdlmf", "s"))
-s <- sample(1:length(d), size = 10000)
-system.time(z <- d[s])
-system.time(y <- readPoints(d, s-1))
-all(z==y)
+d <- createH5Dataset(h5, "jim", cbind(c('jime ', 'joe', 'mikey'),
+ c('jime 2 ', 'joe 2', 'mikey 2')))
+d[]
+writeH5Data(d, c("johnson", "jodhsd"), c(1,0), c(2, 1))
+
m <- createH5Dataset(h5, "mm", cbind(rnorm(1000), rnorm(1000)))
+m[1:10, 2]
+
-d <- createH5Dataset(h5, "dusdf", as.character(1:20))
-writeH5Data(d, "jim", 1, 1)
+d1 <- createH5Dataset(h5, "jon", runif(100000))
+p <- readPoints(d1, ss <- sample(1:length(d1), size = 1000, replace = T))
+all(p == d1[ss])
+
+
+d2 <- createH5Dataset(h5, "jodf", paste(runif(200010)))
+d2[sample(1:length(d2), size = 1000)]
Added: tests/testread.R
===================================================================
--- tests/testread.R (rev 0)
+++ tests/testread.R 2011-04-26 00:42:21 UTC (rev 47)
@@ -0,0 +1,235 @@
+require(h5r)
+
+source("tinyTestHarness.R")
+
+##
+## Make a new TestHarness.
+##
+TH <- TestHarness()
+
+
+##
+## The tests.
+##
+file <- system.file("h5_files", "ex_1.h5", package = 'h5r')
+
+## ex_1
+f <- H5File(file)
+g <- getH5Group(f, "group_1")
+
+TH("group name", g at name == "group_1")
+
+ds1 <- getH5Dataset(g, "ds_1", inMemory = T)
+
+TH("ds_1 dim, 1", all(dim(ds1) == c(1000, 10)))
+TH("ds_1 dim, 2", all(dim(ds1[1:10, 1:10]) == c(10, 10)))
+TH("ds_1 dim, 3", all(dim(ds1[1:10, ]) == c(10, 10)))
+TH("ds_1 dim, 4", is.null(dim(ds1[, 1])))
+TH("ds_1 dim, 5", assertError(ds1[,1:12]))
+
+## test existence.
+TH("existence, 1", h5DatasetExists(g, "ds_1"))
+TH("existence, 2", h5DatasetExists(g, "ds_232") == FALSE)
+
+## string dataset
+ds2M <- getH5Dataset(g, "ds_2", inMemory = T)
+ds2 <- getH5Dataset(g, "ds_2", inMemory = F)
+
+TH("ds_2 dim, 1", all(ds2[] == ds2M[]))
+TH("ds_2 dim, 2", all(ds2[1:5] == ds2M[1:5]))
+
+## attributes
+a <- getH5Attribute(ds2, "x")
+b <- getH5Attribute(ds2, "y")
+c <- getH5Attribute(ds2, "z")
+
+TH("attribute 1", all(a[] == 1:3))
+TH("attribute 2", all(b[] == rbind(1:3, 5:7)))
+TH("attribute 3", all(c[] == ds2[]))
+
+## > 2 dimensional data.
+ds3M <- getH5Dataset(g, "ds_3", inMemory = T)
+ds3 <- getH5Dataset(g, "ds_3", inMemory = F)
+
+TH("ds_3 dim", all(dim(ds3[,,]) == dim(ds3)) && all(dim(ds3M[,,]) == dim(ds3M)))
+
+## known inconsistency between two.
+TH("In memory inconsistency (!! FIXME !!)", assertError(all(ds3M[] == ds3[])))
+
+## the 3d R object.
+id3 <- ds3M at .data$.data
+
+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,,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]) &
+ all(id3[1,,3,drop=TRUE] == ds3M[1,,3,drop=TRUE]))
+
+TH("3d bounds check 1", assertError(ds3[0:10,,]))
+TH("3d bounds check 2", assertError(ds3[,,0:10]))
+TH("3d bounds check 3", assertError(ds3[1,2,1:1000]))
+
+## 2 dimensional string dataset.
+ds4M <- getH5Dataset(g, "ds_4", inMemory = T)
+ds4 <- getH5Dataset(g, "ds_4", inMemory = F)
+
+TH("ds_2 dim", all(dim(ds4[,]) == dim(ds4)) & all(dim(ds4M[,]) == dim(ds4)))
+
+TH("ds_4, memory", (function(n = 100, s = 100) {
+ g1 <- gc()[,1]
+ a <- replicate(n, {
+ replicate(s, getH5Dataset(g, "ds_4", inMemory = FALSE)[1:2,1:2])
+ })
+ rm(a)
+ all(g1 - gc()[,1] <= 0)
+})())
+
+## contiguity problem.
+TH("contiguity", all(ds4M[1, c(2,3,5)] == ds4[1, c(2,3,5)]))
+TH("contiguity - 1D", all(ds2M[c(1, 7, 13)] == ds2[c(1, 7, 13)]))
+
+ds5 <- getH5Dataset(g, "ds_5")
+ds5M <- ds5[]
+
+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)
+id9 <- ds9M[,,,,]
+
+TH("5-d 0", all(id9[] == ds9M[,,,,]) && all(id9[] == ds9[]))
+
+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.
+##
+ds6 <- getH5Dataset(g, "ds_6", inMemory = FALSE)
+ds6M <- getH5Dataset(g, "ds_6", inMemory = TRUE)
+
+TH("ds6, slicing", all(ds6[,] == ds6M[,]) & all(ds6[2:1001] == ds6M[2:1001]))
+
+timeMe <- function(d) {
+ k <- 100
+ n <- 100
+ system.time({
+ for (i in seq.int(1, n)) {
+ b <- runif(1, 1, nrow(d) - k)
+ d[b:(b + k)]
+ }
+ })[3]
+}
+
+## These are *real* upper-bounds on timing.
+TH("slab selection, timing", (mean(replicate(10, timeMe(ds6))) < 1))
+TH("slab selection, timing -- memory", (mean(replicate(10, timeMe(ds6M))) < 1))
+
+randomSlice <- function(d) {
+ dims <- dim(d)
+
+ starts <- floor(runif(length(dims), rep(1, length(dims)), dims))
+ ends <- starts + floor(rexp(length(dims), 1/4))
+ ends <- ifelse(ends > dims, dims, ends)
+
+ lst <- as.list(call("[", d))
+
+ for (i in 1:length(dims)) {
+ lst[[i + 2]] <- starts[i]:ends[i]
+ }
+ eval(as.call(lst))
+}
+
+ds7 <- getH5Dataset(g, "ds_7", inMemory = FALSE)
+ds7M <- getH5Dataset(g, "ds_7", inMemory = TRUE)
+
+TH("random slice", {
+ set.seed(10)
+ system.time({a <- replicate(10000, randomSlice(ds7))})
+ set.seed(10)
+ system.time({b <- replicate(10000, randomSlice(ds7M))})
+ all.equal(a,b)
+})
+
+TH("list attributes, file", {
+ length(listH5Contents(f)) == 15
+})
+
+TH("list attributes, group", {
+ length(listH5Contents(g)) == 12
+})
+
+ds8 <- getH5Dataset(g, "ds_8", inMemory = FALSE)
+
+TH("dim check 1", assertError(ds8[,0:5]))
+TH("dim check 2", assertError(ds8[0,1:5]))
+TH("dim check 3", assertError(ds8[-1,1:5]))
+TH("dim check 4", assertError(ds8[10,1]))
+TH("test 0-vs-1 based", all(ds8[1,1:5] == 1:5))
+
+
+TH("hSlab grab",
+ all(ds8[hSlab(c(1,1), end = c(2,2))] == ds8[1:2, 1:2]) &
+ all(ds8[] == ds8[ hSlab(c(1,1), end = dim(ds8)) ]))
+
+TH("normal time", {
+ all(replicate(10000, {
+ m <- apply(cbind(c(1,1,1), dim(ds7)), 1, function(b) {
+ a <- runif(1, b[1], b[2])
+ floor(c(a, runif(1, a, b[2])))
+ })
+ ds7[m[1,1]:m[2,1],
+ m[1,2]:m[2,2],
+ m[1,3]:m[2,3]]
+ return(TRUE)
+ }))
+})
+
+TH("hSlab time", {
+ all(replicate(10000, {
+ m <- apply(cbind(c(1,1,1), dim(ds7)), 1, function(b) {
+ a <- runif(1, b[1], b[2])
+ floor(c(a, runif(1, a, b[2])))
+ })
+ ds7[hSlab(m[1,], end = m[2,])]
+ return(TRUE)
+ }))
+})
+
+TH("slabs equal", all(readSlab(ds6, 1, 10) == read1DSlabs(ds6, 1, 10)[[1]]))
+TH("slabs equal iteration", {
+ r1 <- read1DSlabs(ds6, 1:10, rep(5, 10))
+ r2 <- lapply(1:10, function(a) {
+ as.integer(readSlab(ds6, a, 5))
+ })
+ all.equal(r1, r2)
+})
+
+
+TH(action = "print")
+TH(action = "throw")
+
Modified: tests/testwrite.R
===================================================================
--- tests/testwrite.R 2011-04-22 23:56:39 UTC (rev 46)
+++ tests/testwrite.R 2011-04-26 00:42:21 UTC (rev 47)
@@ -1,7 +1,5 @@
require(h5r)
-
-system("rm test.h5")
h5 <- H5File("test.h5", 'w')
listH5Contents(h5)
@@ -10,10 +8,13 @@
d <- createH5Dataset(g1, "ds3", dType = "integer", dims = 100)
writeH5Data(d, as.integer(1:10), 0, 10)
writeH5Data(d, as.integer(1:10), 11, 4)
-
+
d <- createH5Dataset(g1, "ds4", dType = "integer", dims = c(10, 2))
writeH5Data(d, as.integer(1:10), c(0, 0), c(5, 2))
writeH5Data(d, as.integer(1:10), c(0, 0), c(10, 2))
d <- createH5Dataset(g1, "ds5", rbind(rnorm(10), rnorm(10)))
d[]
+
+d <- createH5Dataset(g1, "ds6", rbind(rnorm(10), rnorm(10)))
+d[]
More information about the H5r-commits
mailing list