[H5r-commits] r32 - R src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jun 8 21:40:46 CEST 2010
Author: extemporaneousb
Date: 2010-06-08 21:40:45 +0200 (Tue, 08 Jun 2010)
New Revision: 32
Added:
tests/crash.R
Removed:
tests/.Rhistory
Modified:
R/h5R.R
src/h5_wrap.c
tests/testall.R
Log:
Added some tests for error cases.
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2010-06-07 23:59:33 UTC (rev 31)
+++ R/h5R.R 2010-06-08 19:40:45 UTC (rev 32)
@@ -112,8 +112,10 @@
})
setMethod("getH5Group", c("H5Obj", "character"), function(h5Obj, groupName) {
- .H5Group(.Call("h5R_get_group", .ePtr(h5Obj), groupName,
- PACKAGE = 'h5r'), groupName)
+ if (is.null(x <- .Call("h5R_get_group", .ePtr(h5Obj), groupName, PACKAGE = 'h5r')))
+ stop(paste("Group:", groupName, "cannot be opened."))
+
+ .H5Group(x, groupName)
})
setMethod("getH5Dim", "H5DataContainer", function(h5Obj) {
@@ -129,9 +131,19 @@
## call this at *class* instantiation time.
if (missing(fileName))
return(.Object)
+
+ if (! file.exists(fileName)) {
+ stop(paste("Unable to open file:", fileName, "does not exist."))
+ }
+ x <- .Call("h5R_open", fileName, package = "h5R")
+
+ if (is.null(x)) {
+ stop(paste("Problem opening file:", fileName))
+ }
- .Object at ePtr <- .Call("h5R_open", fileName, package = "h5R")
+ .Object at ePtr <- x
.Object at fileName <- fileName
+
return(.Object)
})
@@ -151,14 +163,22 @@
setMethod("getH5Dataset", c("H5Obj", "character"), function(h5Obj, datasetName,
inMemory = FALSE) {
+ if (is.null(x <- .Call("h5R_get_dataset", .ePtr(h5Obj), datasetName, PACKAGE = 'h5r'))) {
+ stop(paste("Dataset:", datasetName, "cannot be opened."))
+ }
+
o <- new("H5Dataset")
- o at ePtr <- .Call("h5R_get_dataset", .ePtr(h5Obj), datasetName, PACKAGE = 'h5r')
+ o at ePtr <- x
return(.initH5DataContainer(o, datasetName, inMemory))
})
setMethod("getH5Attribute", c("H5Obj", "character"), function(h5Obj, attrName) {
+ if (is.null(x <- .Call("h5R_get_attr", .ePtr(h5Obj), attrName, PACKAGE = 'h5r'))) {
+ stop(paste("Attribute:", attrName, "cannot be opened."))
+ }
+
o <- new("H5Attribute")
- o at ePtr <- .Call("h5R_get_attr", .ePtr(h5Obj), attrName, PACKAGE = 'h5r')
+ o at ePtr <- x
return(.initH5DataContainer(o, attrName, inMemory = TRUE))
})
@@ -457,8 +477,7 @@
h5Exists <- function(h5Obj, name) {
a <- .listH5Contents(h5Obj)
n <- sapply(a, "[[", 1)
- s <- sapply(strsplit(n, "/"), "[[", 1)
- any(s == name)
+ any(n == name)
## This call determines if an object exists anywhere in
## the file with 'name'
Modified: src/h5_wrap.c
===================================================================
--- src/h5_wrap.c 2010-06-07 23:59:33 UTC (rev 31)
+++ src/h5_wrap.c 2010-06-08 19:40:45 UTC (rev 32)
@@ -26,13 +26,17 @@
}
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;
}
@@ -53,7 +57,7 @@
}
SEXP h5R_get_type(SEXP h5_obj) {
- SEXP dtype = R_NilValue;
+ SEXP dtype = R_NilValue;
hid_t cls_id = -1;
switch (H5Iget_type(HID(h5_obj))) {
@@ -166,6 +170,7 @@
SEXP _h5R_read_vlen_str(SEXP h5_obj) {
+ int __ERROR__ = 0;
int i = -1;
SEXP res = R_NilValue;
void* buf;
@@ -194,17 +199,20 @@
H5Aread(HID(h5_obj), memtype, buf);
break;
default:
- error("Unsupported class in %s.\n", __func__);
+ __ERROR__ = 1;
}
- PROTECT(res = allocVector(STRSXP, nelts));
- for (i = 0; i < nelts; i++) {
- if (rdata[i]) {
- SET_STRING_ELT(res, i, mkChar(rdata[i]));
+ if (__ERROR__ == 0) {
+ PROTECT(res = allocVector(STRSXP, nelts));
+ for (i = 0; i < nelts; i++) {
+ if (rdata[i]) {
+ SET_STRING_ELT(res, i, mkChar(rdata[i]));
+ }
}
+ UNPROTECT(1);
}
- UNPROTECT(1);
-
+
+ /** Cleanup. **/
if (_h5R_is_vlen(h5_obj)) {
H5Dvlen_reclaim (memtype, _h5R_get_space(h5_obj), H5P_DEFAULT, rdata);
}
@@ -212,10 +220,13 @@
for (i = 0; i < nelts; i++)
Free(rdata[i]);
}
-
Free(rdata);
H5Tclose(memtype);
+ if (__ERROR__ == 1) {
+ error("Unsupported class in %s.\n", __func__);
+ }
+
return res;
}
@@ -249,6 +260,7 @@
}
SEXP h5R_read_slab(SEXP h5_dataset, SEXP _offsets, SEXP _counts) {
+ int __ERROR__ = 0;
SEXP dta = R_NilValue;
hid_t space = -1, memspace = -1, memtype = -1;
void* buf = NULL;
@@ -289,23 +301,26 @@
H5Tset_size (memtype, H5T_VARIABLE);
break;
default:
- error("Unsupported class in %s\n", __func__);
+ __ERROR__ = 1;
}
- 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] ));
- }
+ if (__ERROR__ == 0) {
+ H5Dread(HID(h5_dataset), memtype, memspace, space, H5P_DEFAULT, buf);
- H5Dvlen_reclaim (memtype, memspace, H5P_DEFAULT, buf);
-
- H5Tclose(memtype);
- Free(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);
+ }
}
/** clean up. **/
@@ -316,6 +331,10 @@
UNPROTECT(1);
+ if (__ERROR__ == 1) {
+ error("Unsupported class in %s\n", __func__);
+ }
+
return dta;
}
Deleted: tests/.Rhistory
===================================================================
--- tests/.Rhistory 2010-06-07 23:59:33 UTC (rev 31)
+++ tests/.Rhistory 2010-06-08 19:40:45 UTC (rev 32)
@@ -1,150 +0,0 @@
-ds9[ , , 2:1, 2:1, , ]
-n
-kall
-dims
-dims
-kall
-sapply(kall, class)
-Q
-ds9[ , , , 2:1, 2:1 ]
-kall
-dims
-Q
-ds9[ , , 1:2, 1:2, ])
-ds9[ , , 1:2, 1:2, ]
-c
-c
-dim(ds9[ , , 1:2, 1:2, ])
-c
-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)
-length(listH5Contents(f))
-TH(action='print')
-TH(action='print')
-listH5Contents(g)
-length(listH5Contents(g))
-TH(action='print')
-TH(action='print')
-g
-h5Exists(g, "ds_1")
-g
-h5Exists(g, "ds_2")
-h5Exists(g, "ds_1")
-g
-listH5Contents(g)
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_323432")
-ls9)
-ls()
-f
-h5Exists(g, "group_1")
-listH5Contents(f)
-h5Exists(g, "ds_1")
-h5Exists(g, "group_1")
-h5r:::.listH5Contents
-h5r:::.listH5Contents(f)
-sapply(h5r:::.listH5Contents(f), "[[", 1)
-h5Exists(g, "group_1")
-h5Exists(g, "group_1")
-h5Exists(f, "group_1")
-h5Exists(f, "group_1")
-h5Exists(f, "group_1")
-h5Exists(f, "group_3")
-h5Exists(g, "group_3")
-h5Exists(g, "ds_1")
-h5Exists(g, "ds_sdf1")
-TH(action='print')
-ds7
-dim(ds7)
-c(c(1,1,1), dim(ds7))
-cbind(c(1,1,1), dim(ds7))
-hSlab(cbind(c(1,1,1), dim(ds7)))
-apply((cbind(c(1,1,1), dim(ds7))), runif)
-apply((cbind(c(1,1,1), dim(ds7))), 1, function(b) runif(1, b[1], b[2]))
-floor(apply((cbind(c(1,1,1), dim(ds7))), 1, function(b) runif(1, b[1], b[2])))
-floor(apply((cbind(c(1,1,1), dim(ds7))), 1, function(b) { a <- runif(1, b[1], b[2]); a + floor(runif(1, a, b[2])) })
-)
-floor(apply((cbind(c(1,1,1), dim(ds7))), 1, function(b) { a <- runif(1, b[1], b[2]); c(a, a + floor(runif(1, a, b[2]))) }))
-t(floor(apply((cbind(c(1,1,1), dim(ds7))), 1, function(b) { a <- runif(1, b[1], b[2]); c(a, a + floor(runif(1, a, b[2]))) })))
-m
-traceback()
-m
-m
-m
-m
-apply(m, 2, diff)
-TH(action='print')
-TH(action='print')
-m
-ds7[m[1,1]:m[2,1],
- m[1,2]:m[2,2],
- m[1,3]:m[2,3]]
-)
-)
-)
-TH(action='print')
-TH(action='print')
-TH(action='print')
-ds2
-ds2[]
-dim(ds2[])
-ds3[]
-ds4
-ds5
-ds6
-ds6[]
-class(ds6[])
-ds2
-class(ds2[])
-ds2[]
-drop(ds2[])
-class(drop(ds2[]))
-unclass(drop(ds2[]))
-class(unclass(drop(ds2[])))
-class(drop(ds2[]))
-class(ds2[1:10])
-aperm(ds2[1:10])
-class(aperm(ds2[1:10]))
-class(aperm(ds1[1:10,1]))
-ds1[1:10,1]
-class(ds1[1:10,1])
-ds1[1:10,1]
-ds1[1:10]
-ds2
-ds2[]
-class(ds2[])
-class(ds2[1:10])
-class(aperm(ds2[1:10]))
-ds1[1:10]
-ds1[1:10,1]
-class(ds1[1:10,])
-ds7
-ds7[1:2,1:2,1:2]
-class(ds7[1:2,1:2,1:2])
-?arrau
-?array
-dim(ds2)
-ds2
-dim(ds2[])
-dim(ds2[1:10])
-dim(drop(ds2[1:10]))
-dim(as.vector(ds2[]))
-as.vector(ds2[])
-dim(ds1[])
-dim(ds3[])
-class(ds3[])
-TH(action='print')
-ds2
-ds2[]
-dim(ds2[])
-dim(ds2)
Added: tests/crash.R
===================================================================
--- tests/crash.R (rev 0)
+++ tests/crash.R 2010-06-08 19:40:45 UTC (rev 32)
@@ -0,0 +1,21 @@
+##
+## These are tests which error in hdf5 libraries and should give an R error.
+##
+
+require(h5r)
+
+source("tinyTestHarness.R")
+
+TH <- TestHarness()
+
+file <- system.file("h5_files", "ex_1.h5", package = 'h5r')
+
+f <- H5File(file)
+
+TH("file existence", assertError(d <- H5File("sdfsdf")))
+TH("dataset existence", assertError(x <- getH5Dataset(f, "sdfsf")))
+TH("group existence", assertError(x <- getH5Group(f, "sdfasdf")))
+TH("attribute existence", assertError(getH5Attribute(f, "sfds")))
+
+TH(action='print')
+TH(action='throw')
Modified: tests/testall.R
===================================================================
--- tests/testall.R 2010-06-07 23:59:33 UTC (rev 31)
+++ tests/testall.R 2010-06-08 19:40:45 UTC (rev 32)
@@ -1,59 +1,7 @@
require(h5r)
-## gctorture(TRUE)
+source("tinyTestHarness.R")
-assertError <- function(expr) {
- tryCatch({{expr}; FALSE}, simpleError = function(e) {
- return(TRUE)
- })
-}
-
-TestHarness <- function() {
- tests <- list()
-
- getTime <- function(elt) {
- elt[["time"]][3]
- }
- getResult <- function(elt) {
- elt[["result"]]
- }
- printResults <- function() {
- mwidth <- max(nchar(names(tests))) + 5
- fmtString <- paste("\t%-", mwidth, "s %-10g %-10s\n", sep = "")
-
- cat(sprintf("%s Results for %d tests %s \n\n", paste(rep("-", 30), collapse = ""), length(tests),
- paste(rep("-", 30), collapse = "")))
-
- for (elt in names(tests)) {
- cat(sprintf(fmtString, elt, getTime(tests[[elt]]), getResult(tests[[elt]])))
- }
- }
-
- function(nm, test, action = c("test", "print", "throw")) {
- action <- match.arg(action)
- switch(action,
- test = {
- tm <- system.time({
- b <- tryCatch(test, simpleError = function(e) {
- return(FALSE)
- }, simpleWarning = function(e) return(FALSE))
- })
- tests[[nm]] <<- list("result" = b, "time" = tm)
- },
- print = {
- printResults()
- },
- throw = {
- errs <- ! sapply(tests, getResult)
- if (any(errs)) {
- stop(simpleError(paste("Tests in error:\n", paste(paste("\t", names(tests)[errs], sep = ""),
- collapse = "\n"),
- sep = "")))
- }
- })
- }
-}
-
##
## Make a new TestHarness.
##
More information about the H5r-commits
mailing list