[H5r-commits] r48 - R src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 26 07:22:39 CEST 2011
Author: extemporaneousb
Date: 2011-04-26 07:22:39 +0200 (Tue, 26 Apr 2011)
New Revision: 48
Modified:
R/h5R.R
src/h5_wrap.c
tests/testwrite.R
Log:
Added tests, debugged.
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2011-04-26 00:42:21 UTC (rev 47)
+++ R/h5R.R 2011-04-26 05:22:39 UTC (rev 48)
@@ -167,11 +167,12 @@
## Writing.
##
.flush <- function(h5Obj) {
- .myCall("h5R_flush", .ePtr(h5Obj))
+ .myCall("h5R_flush", .ePtr(h5Obj))
}
setMethod("writeH5Data", c("H5Dataset"), function(h5Obj, data, offsets, extents) {
- .myCall("h5R_write_slab", .ePtr(h5Obj), as.integer(offsets) - 1, as.integer(extents), data)
+ storage.mode(data) <- h5r:::.h5Types[getH5Type(h5Obj) + 1]
+ .myCall("h5R_write_slab", .ePtr(h5Obj), as.integer(offsets - 1), as.integer(extents), data)
})
setMethod("createH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, data,
@@ -240,24 +241,27 @@
}
}
- if (.myCall("h5R_create_group", .ePtr(h5Obj), groupName) == 0) {
- .flush(h5Obj)
- return(getH5Group(h5Obj, groupName))
+ if (.myCall("h5R_create_group", .ePtr(h5Obj), groupName)) {
+ .flush(h5Obj)
+ return(getH5Group(h5Obj, groupName))
} else {
- stop(paste("Unable to create group:", groupName))
+ stop(paste("Unable to create group:", groupName))
}
})
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.")
- }
+ ###
+ ## gota close everything.
+ ##
+ if (h5AttributeExists(h5Obj, attrName)) {
+ if (overwrite) {
+ deleteH5Attribute(h5Obj, attrName)
+ } 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
@@ -268,19 +272,27 @@
nr <- nrow(attrValue)
nc <- ncol(attrValue)
}
+
.Call("h5R_create_attribute", .ePtr(h5Obj), as.character(attrName), as.integer(dType),
as.integer(c(nr, nc)))
+ .flush(h5Obj)
+ .flush(getH5Attribute(h5Obj, attrName))
+ browser()
+
.Call("h5R_write_attribute", .ePtr(getH5Attribute(h5Obj, attrName)), attrValue)
.flush(h5Obj)
})
setMethod("deleteH5Obj", c("H5Container"), function(h5Obj, h5ObjName) {
- .myCall("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName))
- .flush(h5Obj)
+ if (h5ObjectExists(h5Obj, h5ObjName)) {
+ return(.myCall("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName)) && .flush(h5Obj))
+ } else {
+ return(FALSE)
+ }
})
setMethod("deleteH5Attribute", c("H5Obj"), function(h5Obj, attrName) {
- .myCall("h5R_delete_attribute", .ePtr(h5Obj), as.character(attrName))
+ .myCall("h5R_delete_attribute", .ePtr(h5Obj), as.character(attrName)) && .flush(h5Obj)
})
##
@@ -588,16 +600,20 @@
return(lst)
}
+h5ObjectExists <- function(h5Obj, name) {
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+}
+
h5GroupExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5DatasetExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5AttributeExists <- function(h5Obj, name) {
- .myCall("h5R_attribute_exists", .ePtr(h5Obj), name) == 1
+ .myCall("h5R_attribute_exists", .ePtr(h5Obj), name)
}
Modified: src/h5_wrap.c
===================================================================
--- src/h5_wrap.c 2011-04-26 00:42:21 UTC (rev 47)
+++ src/h5_wrap.c 2011-04-26 05:22:39 UTC (rev 48)
@@ -9,8 +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))
+#define SUCCESS ScalarLogical(1)
+#define FAILURE ScalarLogical(0)
typedef struct h5_holder {
int is_file;
@@ -379,8 +379,10 @@
if (__ERROR__ == 1) {
error("Unsupported class in %s\n", __func__);
+ return FAILURE;
}
- return R_NilValue;
+
+ return SUCCESS;
}
@@ -607,8 +609,11 @@
void* buf = NULL;
char** tmp = NULL;
int i;
+ int atype = INTEGER(h5R_get_type(h5_attr))[0];
- switch (INTEGER(h5R_get_type(h5_attr))[0]) {
+ Rprintf("atype is: %d\n", atype);
+
+ switch (atype) {
case H5T_INTEGER:
buf = INTEGER(data);
memtype = H5T_NATIVE_INT;
@@ -667,11 +672,21 @@
* File content inspection and iteration.
*/
SEXP h5R_attribute_exists(SEXP h5_obj, SEXP name) {
- return(ScalarInteger(H5Aexists(HID(h5_obj), NM(name))));
+ if (H5Aexists(HID(h5_obj), NM(name)) == 1) {
+ return SUCCESS;
+ }
+ else {
+ return FAILURE;
+ }
}
SEXP h5R_dataset_exists(SEXP h5_obj, SEXP name) {
- return(ScalarInteger(H5Lexists(HID(h5_obj), NM(name), H5P_DEFAULT)));
+ if (H5Lexists(HID(h5_obj), NM(name), H5P_DEFAULT) == 1) {
+ return SUCCESS;
+ }
+ else {
+ return FAILURE;
+ }
}
@@ -764,9 +779,3 @@
}
}
-SEXP h5R_name_exists(SEXP h5_obj, SEXP _name) {
- const char* name = NM(_name);
- herr_t v = H5Ovisit (HID(h5_obj), H5_INDEX_NAME, H5_ITER_NATIVE, _h5R_name_exists,
- (void*) name);
- return ScalarLogical(v);
-}
Modified: tests/testwrite.R
===================================================================
--- tests/testwrite.R 2011-04-26 00:42:21 UTC (rev 47)
+++ tests/testwrite.R 2011-04-26 05:22:39 UTC (rev 48)
@@ -1,20 +1,75 @@
require(h5r)
-h5 <- H5File("test.h5", 'w')
+source("tinyTestHarness.R")
-listH5Contents(h5)
+##
+## Make a new TestHarness.
+##
+TH <- TestHarness()
-g1 <- createH5Group( h5, "grp1" )
-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))
+fileName <- "test.h5"
-d <- createH5Dataset(g1, "ds5", rbind(rnorm(10), rnorm(10)))
-d[]
+TH("file create", { h5 <- H5File(fileName, 'w'); TRUE })
+TH("file remove", { fn <- h5 at fileName; rm(h5) ; gc() ; file.remove(fn); TRUE })
-d <- createH5Dataset(g1, "ds6", rbind(rnorm(10), rnorm(10)))
-d[]
+h5 <- H5File(fileName, 'w')
+
+TH("group create 1", { g1 <- createH5Group( h5, "grp1" ); TRUE })
+TH("group create 2", {createH5Group( g1, "grp1-1" ); TRUE })
+TH("group create 3", {createH5Group( g1, "grp1-2" ); TRUE })
+
+TH("group exists 1", all(names(listH5Contents(h5)) == c(".", "grp1", "grp1/grp1-1", "grp1/grp1-2")))
+TH("group delete 1", deleteH5Obj(h5, "grp1/grp1-2"))
+TH("group exists 2", all(names(listH5Contents(h5)) == c(".", "grp1", "grp1/grp1-1")))
+
+TH("dataset exists 1", {
+ d <- createH5Dataset(g1, "d1", dims = c(10, 10), dType = "integer")
+ all(dim(d) == c(10, 10))
+})
+
+TH("dataset write 1", {
+ indta <- as.integer(outer(1:10, 1:10))
+ writeH5Data(d, data = indta, offsets = as.integer(c(1, 1)), extents = as.integer(c(10, 10)))
+ all(d[] == indta)
+
+ mdta <- rbind(as.integer(c(rep(1, 10), rep(2, 10))))
+ writeH5Data(d, data = mdta, offsets = as.integer(c(1, 1)), extents = as.integer(c(2, 10)))
+ indta[1:20] <- mdta
+
+ ## the by-column ordering vs. by-row.
+ all(indta == t(rbind(d[1:2,], d[3:10,])))
+})
+
+TH("string dataset create 1", {
+ d <- createH5Dataset(g1, "d2", z <- as.character(runif(1000)))
+ (all(d[1:10] == z[1:10]) &&
+ all(z[1:10]==unlist(read1DSlabs(d, 1:10, rep(1, 10)))))
+})
+
+TH("string dataset create 2", {
+ d <- createH5Dataset(g1, "d3", z <- cbind(as.character(runif(1000)), as.character(runif(1000))))
+ (all(d[1:2,1] == z[1:2, 1]) && all(z[1:2, 1] == readSlab(d, c(1,1), c(2, 1))))
+})
+
+TH("attribute creation 1", {
+ createH5Attribute(g1, "jim", 20:1)
+})
+TH("attribute fetch 1", {
+ all(getH5Attribute(g1, "jim")[] == 20:1)
+})
+TH("attribute deletion 1", {
+ deleteH5Attribute(g1, "jim")
+})
+
+TH("attribute creation 2", {
+ createH5Attribute(g1, "jim", as.character(20:1))
+})
+TH("attribute fetch 2", {
+ all(getH5Attribute(g1, "jim")[] == as.character(20:1))
+})
+TH("attribute deletion 2", {
+ deleteH5Attribute(g1, "jim")
+})
+
+TH(action = 'print')
+
More information about the H5r-commits
mailing list