[H5r-commits] r50 - / R src tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 26 18:34:18 CEST 2011
Author: extemporaneousb
Date: 2011-04-26 18:34:18 +0200 (Tue, 26 Apr 2011)
New Revision: 50
Modified:
NAMESPACE
R/h5R.R
src/h5_wrap.c
tests/testwrite.R
Log:
a number of changes
Modified: NAMESPACE
===================================================================
--- NAMESPACE 2011-04-26 15:24:00 UTC (rev 49)
+++ NAMESPACE 2011-04-26 16:34:18 UTC (rev 50)
@@ -8,7 +8,8 @@
H5Group,
H5Dataset,
H5Attribute,
- H5DataContainer)
+ H5DataContainer,
+ H5Container)
importMethodsFrom(methods, show)
@@ -17,6 +18,11 @@
getH5Type,
getH5Dataset,
getH5Attribute,
+ createH5Group,
+ createH5Attribute,
+ writeH5Data,
+ deleteH5Obj,
+ deleteH5Attribute,
readH5Data,
show,
ncol,
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2011-04-26 15:24:00 UTC (rev 49)
+++ R/h5R.R 2011-04-26 16:34:18 UTC (rev 50)
@@ -74,6 +74,31 @@
return(o)
}
+.initH5DataContainer <- function(o, name, inMemory) {
+ o at name <- name
+ o at h5Type <- getH5Type(o)
+ o at dims <- getH5Dim(o)
+
+ if (! inMemory) {
+ o at .data <- NULL
+ } else {
+ o at .data <- new.env(parent = emptyenv(), hash = TRUE)
+ }
+ return(o)
+}
+
+.H5Attribute <- function(ep, name, inMemory = TRUE) {
+ o <- new("H5Attribute")
+ o at ePtr <- ep
+ return(.initH5DataContainer(o, name, inMemory = inMemory))
+}
+
+.H5Dataset <- function(ep, name, inMemory = FALSE) {
+ o <- new("H5Dataset")
+ o at ePtr <- ep
+ return(.initH5DataContainer(o, name, inMemory = inMemory))
+}
+
.hasData <- function(h5DataContainer) {
return(exists(".data", h5DataContainer at .data))
}
@@ -115,7 +140,7 @@
if (! file.exists(fileName) && mode == 'w') {
.myCall("h5R_create", fileName, package = "h5R")
}
-
+
if (! file.exists(fileName)) {
stop(paste("Unable to open file:", fileName, "does not exist."))
}
@@ -131,48 +156,30 @@
return(.Object)
})
-.initH5DataContainer <- function(o, name, inMemory) {
- o at name <- name
- o at h5Type <- getH5Type(o)
- o at dims <- getH5Dim(o)
-
- if (! inMemory) {
- o at .data <- NULL
- } else {
- o at .data <- new.env(parent = emptyenv(), hash = TRUE)
- }
-
- return(o)
-}
-
setMethod("getH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, inMemory = FALSE) {
if (is.null(x <- .myCall("h5R_get_dataset", .ePtr(h5Obj), datasetName))) {
stop(paste("Dataset:", datasetName, "cannot be opened."))
}
- o <- new("H5Dataset")
- o at ePtr <- x
- return(.initH5DataContainer(o, datasetName, inMemory))
+ return(.H5Dataset(x, datasetName, inMemory = inMemory))
})
setMethod("getH5Attribute", c("H5Obj", "character"), function(h5Obj, attrName) {
if (is.null(x <- .myCall("h5R_get_attr", .ePtr(h5Obj), attrName))) {
- stop(paste("Attribute:", attrName, "cannot be opened."))
+ stop(paste("Attribute:", attrName, "cannot be opened."))
}
- o <- new("H5Attribute")
- o at ePtr <- x
- return(.initH5DataContainer(o, attrName, inMemory = TRUE))
+ return(.H5Attribute(x, attrName, inMemory = TRUE))
})
##
## Writing.
##
.flush <- function(h5Obj) {
- .myCall("h5R_flush", .ePtr(h5Obj))
+ .myCall("h5R_flush", .ePtr(h5Obj))
}
setMethod("writeH5Data", c("H5Dataset"), function(h5Obj, data, offsets, extents) {
- storage.mode(data) <- h5r:::.h5Types[getH5Type(h5Obj) + 1]
- .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,
@@ -219,16 +226,17 @@
if (mChnk)
chunkSizes <- rep(4096, length(dims))
- .myCall("h5R_create_dataset", .ePtr(h5Obj), datasetName, iType, dims, as.integer(chunkSizes))
-
+ h5Dataset <- .H5Dataset(.myCall("h5R_create_dataset", .ePtr(h5Obj), datasetName, iType, dims, as.integer(chunkSizes)),
+ datasetName)
+
if (! mData) {
- writeH5Data(getH5Dataset(h5Obj, datasetName), data,
- as.integer(rep(1L, length(dims))),
- as.integer(dims))
+ if(! writeH5Data(h5Dataset, data,
+ as.integer(rep(1L, length(dims))),
+ as.integer(dims))) stop("Unable to write data.")
}
.flush(h5Obj)
- return(getH5Dataset(h5Obj, datasetName))
+ return(h5Dataset)
})
setMethod("createH5Group", c("H5Container", "character"), function(h5Obj, groupName,
@@ -240,25 +248,18 @@
deleteH5Obj(h5Obj, groupName)
}
}
-
- if (.myCall("h5R_create_group", .ePtr(h5Obj), groupName)) {
- .flush(h5Obj)
- return(getH5Group(h5Obj, groupName))
- } else {
- stop(paste("Unable to create group:", groupName))
- }
+ h5Group <- .H5Group(.myCall("h5R_create_group", .ePtr(h5Obj), groupName), groupName)
+ .flush(h5Obj)
+ return(h5Group)
})
setMethod("createH5Attribute", c("H5Obj"), function(h5Obj, attrName, attrValue, overwrite = TRUE) {
- ###
- ## gota close everything.
- ##
- if (h5AttributeExists(h5Obj, attrName)) {
- if (overwrite) {
- deleteH5Attribute(h5Obj, attrName)
- } else {
- stop("Attribute exists, delete first, or specify overwrite.")
- }
+ 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)
@@ -273,22 +274,22 @@
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)
+ h5Attr <- .H5Attribute(.Call("h5R_create_attribute", .ePtr(h5Obj), as.character(attrName),
+ as.integer(dType),
+ as.integer(c(nr, nc))), attrName)
+ if (.Call("h5R_write_attribute", .ePtr(h5Attr), attrValue) && .flush(h5Obj)) {
+ return(h5Attr)
+ } else {
+ stop("Unable to create attribute.")
+ }
})
setMethod("deleteH5Obj", c("H5Container"), function(h5Obj, h5ObjName) {
- if (h5ObjectExists(h5Obj, h5ObjName)) {
- return(.myCall("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName)) && .flush(h5Obj))
- } else {
- return(FALSE)
- }
+ 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) {
@@ -420,7 +421,7 @@
.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))
@@ -601,23 +602,23 @@
}
h5ObjectExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5GroupExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5DatasetExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5AttributeExists <- function(h5Obj, name) {
- .myCall("h5R_attribute_exists", .ePtr(h5Obj), name)
+ .myCall("h5R_attribute_exists", .ePtr(h5Obj), name)
}
-
+
################################################################
##
## H5DataFrame interface
@@ -679,7 +680,7 @@
## "\nmissingI:", missingI,
## "\nclass I:", if (! missingI) class(i) else "missing",
## "\nclass J:", if (! missingJ) class(j) else "missing"), "\n")
-
+
if (missingJ && missingI) {
## [] -- return everything.
## -> data.frame
@@ -729,8 +730,8 @@
})
setMethod("[[", c("H5DataFrame", "ANY", "ANY"), function(x, i, j) {
- missingI <- missingJ <- FALSE
-
+ missingI <- missingJ <- FALSE
+
if (missing(j)) missingJ <- TRUE
if (missing(i)) missingI <- TRUE
@@ -739,8 +740,8 @@
## "\nclass I:", if (! missingI) class(i) else "missing",
## "\nclass J:", if (! missingJ) class(j) else "missing"), "\n")
- if (!missingI && missingJ) {
- x at h5Datasets[[i]][]
+ if (!missingI && missingJ) {
+ x at h5Datasets[[i]][]
}
})
Modified: src/h5_wrap.c
===================================================================
--- src/h5_wrap.c 2011-04-26 15:24:00 UTC (rev 49)
+++ src/h5_wrap.c 2011-04-26 16:34:18 UTC (rev 50)
@@ -23,6 +23,20 @@
if (h->is_file == 1) {
H5Fflush(HID(h5_obj), H5F_SCOPE_GLOBAL);
H5Fclose(HID(h5_obj));
+ } else {
+ switch (H5Iget_type(HID(h5_obj))) {
+ case H5I_DATASET:
+ H5Dclose(HID(h5_obj));
+ break;
+ case H5I_ATTR:
+ H5Aclose(HID(h5_obj));
+ break;
+ case H5I_GROUP:
+ H5Gclose(HID(h5_obj));
+ break;
+ default:
+ error("Tried finalize type: %d.\n", H5Iget_type(HID(h5_obj)));
+ }
}
Free(h);
}
@@ -58,9 +72,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 SUCCESS;
+ return _h5R_make_holder(H5Gcreate(HID(h5_obj), NM(group_name), H5P_DEFAULT, H5P_DEFAULT, H5P_DEFAULT), 0);
}
SEXP h5R_get_dataset(SEXP h5_obj, SEXP dataset_name) {
@@ -301,8 +313,7 @@
default:
error("Unsupported class in %s.\n", __func__);
}
-
-
+
hid_t cparms = H5Pcreate(H5P_DATASET_CREATE);
H5Pset_chunk(cparms, length(chunks), chunk_lens);
@@ -311,13 +322,13 @@
dataspace, H5P_DEFAULT, cparms, H5P_DEFAULT);
H5Pclose(cparms);
- H5Dclose(dataset);
H5Sclose(dataspace);
+
Free(max_dims);
Free(current_dims);
Free(chunk_lens);
- return SUCCESS;
+ return _h5R_make_holder(dataset, 0);
}
SEXP h5R_write_slab(SEXP h5_dataset, SEXP _offsets, SEXP _counts, SEXP data) {
@@ -381,7 +392,6 @@
error("Unsupported class in %s\n", __func__);
return FAILURE;
}
-
return SUCCESS;
}
@@ -596,12 +606,11 @@
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;
+ return _h5R_make_holder(attribute, 0);
}
SEXP h5R_write_attribute(SEXP h5_attr, SEXP data) {
@@ -610,9 +619,7 @@
char** tmp = NULL;
int i;
int atype = INTEGER(h5R_get_type(h5_attr))[0];
-
- Rprintf("atype is: %d\n", atype);
-
+
switch (atype) {
case H5T_INTEGER:
buf = INTEGER(data);
@@ -635,8 +642,11 @@
}
H5Awrite(HID(h5_attr), memtype, buf);
- // XXX FREE ! ! !
-
+ if (atype == H5T_STRING) {
+ Free(tmp);
+ H5Tclose(memtype);
+ }
+ H5Aclose(HID(h5_attr));
return SUCCESS;
}
Modified: tests/testwrite.R
===================================================================
--- tests/testwrite.R 2011-04-26 15:24:00 UTC (rev 49)
+++ tests/testwrite.R 2011-04-26 16:34:18 UTC (rev 50)
@@ -52,7 +52,8 @@
})
TH("attribute creation 1", {
- createH5Attribute(g1, "jim", 20:1)
+ atr <- createH5Attribute(g1, "jim", 20:1)
+ atr at name == "jim"
})
TH("attribute fetch 1", {
all(getH5Attribute(g1, "jim")[] == 20:1)
@@ -62,7 +63,8 @@
})
TH("attribute creation 2", {
- createH5Attribute(g1, "jim", as.character(20:1))
+ atr <- createH5Attribute(g1, "jim", as.character(20:1))
+ atr at name == "jim"
})
TH("attribute fetch 2", {
all(getH5Attribute(g1, "jim")[] == as.character(20:1))
More information about the H5r-commits
mailing list