[H5r-commits] r96 - / R inst tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jul 8 23:52:52 CEST 2013
Author: extemporaneousb
Date: 2013-07-08 23:52:52 +0200 (Mon, 08 Jul 2013)
New Revision: 96
Modified:
DESCRIPTION
R/h5R.R
inst/CRAN_prepare_h5r.sh
tests/Makefile
tests/testCompound.R
tests/testGetGroup.R
tests/testReadPoints.R
tests/testWrite.R
Log:
Fixed problem with .Call and registration for 3.1 check consistency. Also fixed a bug where createH5Dataset would ignore the dimensions and type argument -- thanks to d. alexander for the report.
Modified: DESCRIPTION
===================================================================
--- DESCRIPTION 2013-07-02 20:14:29 UTC (rev 95)
+++ DESCRIPTION 2013-07-08 21:52:52 UTC (rev 96)
@@ -1,7 +1,7 @@
Package: h5r
Type: Package
Title: Interface to HDF5 Files
-Version: 1.4.6
+Version: 1.4.7
Date: 2011-09-19
Author: James Bullard
Maintainer: James Bullard <jbullard at pacificbiosciences.com>
Modified: R/h5R.R
===================================================================
--- R/h5R.R 2013-07-02 20:14:29 UTC (rev 95)
+++ R/h5R.R 2013-07-08 21:52:52 UTC (rev 96)
@@ -49,13 +49,9 @@
## ##############################################################################
##
-## C-helper
+## C-helpers
##
## ##############################################################################
-.myCall <- function(nm, ...) {
- .Call(nm, ..., PACKAGE = 'h5r')
-}
-
H5File <- function(fileName, mode = 'r') {
new("H5File", fileName, mode)
}
@@ -117,21 +113,21 @@
}
.openObjects <- function(h5File) {
- .myCall("h5R_get_object_count", .ePtr(h5File))
+ .Call("h5R_get_object_count", .ePtr(h5File))
}
setMethod("getH5Group", c("H5Container", "character"), function(h5Obj, groupName) {
- if (is.null(x <- .myCall("h5R_get_group", .ePtr(h5Obj), groupName)))
+ if (is.null(x <- .Call("h5R_get_group", .ePtr(h5Obj), groupName)))
stop(paste("Group:", groupName, "cannot be opened."))
.H5Group(x, groupName)
})
setMethod("getH5Dim", "H5DataContainer", function(h5Obj) {
- .myCall('h5R_get_dims', .ePtr(h5Obj))
+ .Call('h5R_get_dims', .ePtr(h5Obj))
})
setMethod("getH5Type", "H5DataContainer", function(h5Obj) {
- .myCall("h5R_get_type", .ePtr(h5Obj))
+ .Call("h5R_get_type", .ePtr(h5Obj))
})
setMethod("initialize", c("H5File"), function(.Object, fileName, mode = c('r', 'w')) {
@@ -142,14 +138,14 @@
mode <- match.arg(mode)
if (! file.exists(fileName) && mode == 'w') {
- .myCall("h5R_create", fileName)
+ .Call("h5R_create", fileName)
}
if (! file.exists(fileName)) {
stop(paste("Unable to open file:", fileName, "does not exist."))
}
## convert the fileName - essentially for ~.
fileName <- normalizePath(fileName)
- x <- .myCall("h5R_open", fileName, if (mode == 'r') as.integer(0) else as.integer(1))
+ x <- .Call("h5R_open", fileName, if (mode == 'r') as.integer(0) else as.integer(1))
if (is.null(x)) {
stop(paste("Problem opening file:", fileName))
}
@@ -160,14 +156,14 @@
})
setMethod("getH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, inMemory = FALSE) {
- if (is.null(x <- .myCall("h5R_get_dataset", .ePtr(h5Obj), datasetName))) {
+ if (is.null(x <- .Call("h5R_get_dataset", .ePtr(h5Obj), datasetName))) {
stop(paste("Dataset:", datasetName, "cannot be opened."))
}
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))) {
+ if (is.null(x <- .Call("h5R_get_attr", .ePtr(h5Obj), attrName))) {
stop(paste("Attribute:", attrName, "cannot be opened."))
}
return(.H5Attribute(x, attrName, inMemory = TRUE))
@@ -177,38 +173,46 @@
## Writing.
##
.flush <- function(h5Obj) {
- .myCall("h5R_flush", .ePtr(h5Obj))
+ .Call("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)
+ .Call("h5R_write_slab", .ePtr(h5Obj), as.integer(offsets - 1), as.integer(extents),
+ data)
})
-setMethod("createH5Dataset", c("H5Container", "character"), function(h5Obj, datasetName, data,
- dims, dType = c("integer", "double", "character"),
- chunkSizes = NA, overwrite = TRUE) {
+setMethod("createH5Dataset", c("H5Container", "character"),
+ function(h5Obj, datasetName, data,
+ dims, dType = c("integer", "double", "character"),
+ chunkSizes = NA, overwrite = TRUE) {
if (h5DatasetExists(h5Obj, datasetName)) {
if (! overwrite)
stop(paste("Dataset:", datasetName, "already exists."))
else
deleteH5Obj(h5Obj, datasetName)
}
-
mData <- missing(data)
mDims <- missing(dims)
mType <- missing(dType)
mChnk <- missing(chunkSizes)
if (mData && (mDims || mType)) {
- stop("Must specify either data or dimensions and type.")
+ stop("Must specify either data, dimensions and type, or all three.")
}
- if (mData && mType) {
- storage.mode(data) <- dType
- }
-
- if (! mData) {
+ if (! mData) {
+ ## set the dType
+ if (! mType) {
+ storage.mode(data) <- match.arg(dType)
+ } else {
+ dType <- storage.mode(data)
+ }
+ ## set the dims if they are given
+ if (! mDims) {
+ dim(data) <- dims
+ }
+ ## query and permute if needed
if (is.null(dim(data))) {
dims <- length(data)
} else {
@@ -216,22 +220,20 @@
dims <- dim(data)
data <- aperm(data)
}
- dType <- storage.mode(data)
- } else {
- dType <- match.arg(dType)
}
- iType <- as.integer(match(dType, .h5Types) - 1)
+ ## set the H5 Type
+ iType <- as.integer(match(dType, .h5Types) - 1)
if (is.na(iType)) {
stop("Type is not resolveable.")
}
- dims <- as.integer(dims)
- if (mChnk)
- chunkSizes <- rep(4096, length(dims))
-
- h5Dataset <- .H5Dataset(.myCall("h5R_create_dataset", .ePtr(h5Obj), datasetName, iType, dims, as.integer(chunkSizes)),
- datasetName)
+ dims <- as.integer(dims)
+ if (mChnk) {
+ chunkSizes <- rep(1, length(dims))
+ }
+ h5Dataset <- .H5Dataset(.Call("h5R_create_dataset", .ePtr(h5Obj), datasetName,
+ iType, dims, as.integer(chunkSizes)), datasetName)
if (! mData) {
if(! writeH5Data(h5Dataset, data,
as.integer(rep(1L, length(dims))),
@@ -251,7 +253,7 @@
deleteH5Obj(h5Obj, groupName)
}
}
- h5Group <- .H5Group(.myCall("h5R_create_group", .ePtr(h5Obj), groupName), groupName)
+ h5Group <- .H5Group(.Call("h5R_create_group", .ePtr(h5Obj), groupName), groupName)
.flush(h5Obj)
return(h5Group)
})
@@ -289,14 +291,14 @@
setMethod("deleteH5Obj", c("H5Container"), function(h5Obj, h5ObjName) {
if (h5ObjectExists(h5Obj, h5ObjName)) {
- return(.myCall("h5R_delete_object", .ePtr(h5Obj), as.character(h5ObjName)) && .flush(h5Obj))
+ return(.Call("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)) && .flush(h5Obj)
+ .Call("h5R_delete_attribute", .ePtr(h5Obj), as.character(attrName)) && .flush(h5Obj)
})
##
@@ -503,13 +505,13 @@
}
read1DSlabs <- function(h5Dataset, offsets, dims) {
- .myCall("h5R_read_1d_slabs", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
+ .Call("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 <- .myCall("h5R_read_dataset", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
+ d <- .Call("h5R_read_dataset", .ePtr(h5Dataset), as.integer(offsets - 1), as.integer(dims))
if (class(d) != 'list') ## compound datasets produce lists.
dim(d) <- rev(dims)
@@ -524,22 +526,15 @@
} else {
stop("readPoints doesn't work on higher dimensional data.")
}
- .myCall("h5R_read_points", .ePtr(h5Dataset), as.integer(idxs - 1), as.integer(nr), as.integer(nc))
+ .Call("h5R_read_points", .ePtr(h5Dataset), as.integer(idxs - 1), as.integer(nr), as.integer(nc))
}
setMethod("readH5Data", "H5Dataset", function(h5Obj) {
- ## nndims <- if (is.null(dim(h5Obj))) {
- ## length(h5Obj)
- ## } else {
- ## dim(h5Obj)
- ## }
- ## .myCall('h5R_read_dataset', .ePtr(h5Obj), as.integer(rep(0, length(nndims))), as.integer(nndims));
-
- .myCall('h5R_read_dataset_all', .ePtr(h5Obj))
+ .Call('h5R_read_dataset_all', .ePtr(h5Obj))
})
setMethod("readH5Data", "H5Attribute", function(h5Obj) {
- .myCall('h5R_read_attr', .ePtr(h5Obj))
+ .Call('h5R_read_attr', .ePtr(h5Obj))
})
setMethod("show", "H5Obj", function(object) {
@@ -583,8 +578,8 @@
##
## construct a list of elements in the file.
-.listH5Contents <- function(h5Obj) .myCall("h5R_list_contents", .ePtr(h5Obj))
-listH5Attributes <- function(h5Obj) .myCall("h5R_list_attributes", .ePtr(h5Obj))
+.listH5Contents <- function(h5Obj) .Call("h5R_list_contents", .ePtr(h5Obj))
+listH5Attributes <- function(h5Obj) .Call("h5R_list_attributes", .ePtr(h5Obj))
listH5Contents <- function(h5Obj) {
contents <- .listH5Contents(h5Obj)
@@ -616,19 +611,19 @@
})
h5ObjectExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .Call("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5GroupExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .Call("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5DatasetExists <- function(h5Obj, name) {
- .myCall("h5R_dataset_exists", .ePtr(h5Obj), name)
+ .Call("h5R_dataset_exists", .ePtr(h5Obj), name)
}
h5AttributeExists <- function(h5Obj, name) {
- .myCall("h5R_attribute_exists", .ePtr(h5Obj), name)
+ .Call("h5R_attribute_exists", .ePtr(h5Obj), name)
}
Modified: inst/CRAN_prepare_h5r.sh
===================================================================
--- inst/CRAN_prepare_h5r.sh 2013-07-02 20:14:29 UTC (rev 95)
+++ inst/CRAN_prepare_h5r.sh 2013-07-08 21:52:52 UTC (rev 96)
@@ -2,6 +2,7 @@
SOURCE=h5r
TARGET=scratch/h5r-CRAN
+RCMD=/home/UNIXHOME/jbullard/projects/software/R/common/R-3.1-install/bin/R
rm -rf $TARGET
rsync -av $SOURCE/ $TARGET/
@@ -21,10 +22,10 @@
echo 'PKG_LIBS = -lm -L$(LIB_HDF5)$(R_ARCH)/lib -lhdf5 -lsz -lz' >> $TARGET/src/Makevars.win
# 4. build
-R CMD build $TARGET
+$RCMD CMD build $TARGET
BUILT_TARGET=h5r_`cat $TARGET/DESCRIPTION | grep Version | sed 's/Version: //g'`.tar.gz
# 5. check
-R CMD check --as-cran --timings --install-args="--no-lock --preclean" $BUILT_TARGET
+$RCMD CMD check --as-cran --timings --install-args="--no-lock --preclean" $BUILT_TARGET
Modified: tests/Makefile
===================================================================
--- tests/Makefile 2013-07-02 20:14:29 UTC (rev 95)
+++ tests/Makefile 2013-07-08 21:52:52 UTC (rev 96)
@@ -1,15 +1,18 @@
+export RCMD=R-devel
+
clean :
- rm -f *.Rout *.h5
+ rm -f *.Rout *.h5 .Rhistory
all :
- R CMD BATCH --no-save testRead.R &
- R CMD BATCH --no-save testReadPoints.R &
- R CMD BATCH --no-save testWrite.R &
- R CMD BATCH --no-save testErrors.R &
- R CMD BATCH --no-save testGetGroup.R &
+ ${RCMD} CMD BATCH --no-save testRead.R &
+ ${RCMD} CMD BATCH --no-save testReadPoints.R &
+ ${RCMD} CMD BATCH --no-save testWrite.R &
+ ${RCMD} CMD BATCH --no-save testErrors.R &
+ ${RCMD} CMD BATCH --no-save testGetGroup.R &
+ ${RCMD} CMD BATCH --no-save testCompound.R &
valgrind:
- R -d "valgrind --tool=memcheck --leak-check=full" --vanilla < testGetGroup.R
+ ${RCMD} -d "valgrind --tool=memcheck --leak-check=full" --vanilla < testGetGroup.R
Modified: tests/testCompound.R
===================================================================
--- tests/testCompound.R 2013-07-02 20:14:29 UTC (rev 95)
+++ tests/testCompound.R 2013-07-08 21:52:52 UTC (rev 96)
@@ -21,4 +21,6 @@
all(as.data.frame(d[1:10]) == as.data.frame(d[10:1])[10:1,]))
}
+TH(action = 'print')
+TH(action = 'throw')
Modified: tests/testGetGroup.R
===================================================================
--- tests/testGetGroup.R 2013-07-02 20:14:29 UTC (rev 95)
+++ tests/testGetGroup.R 2013-07-08 21:52:52 UTC (rev 96)
@@ -1,14 +1,22 @@
require(h5r)
-##
-## The tests.
-##
+source('tinyTestHarness.R')
+TH <- TestHarness()
+
file <- system.file("h5_files", "ex_1.h5", package = 'h5r')
f <- H5File(file)
-gc()
-v <- replicate(1000, {
- getH5Group(f, "group_1")
+TH('get group', {
+ ## Not quite sure how to really do this right, I don't expect the
+ ## memory to always go back to the original state.
+ g = gc()
+ v <- replicate(1000, {
+ getH5Group(f, "group_1")
+ })
+ rm(v)
+ gc()
+ TRUE
})
-rm(v)
-lapply(1:5, function(i) gc())
+
+TH(action = 'print')
+TH(action = 'throw')
Modified: tests/testReadPoints.R
===================================================================
--- tests/testReadPoints.R 2013-07-02 20:14:29 UTC (rev 95)
+++ tests/testReadPoints.R 2013-07-08 21:52:52 UTC (rev 96)
@@ -1,24 +1,41 @@
require(h5r)
-h5 <- H5File("test.h5", 'w')
+source("tinyTestHarness.R")
-createH5Attribute(h5, "e", 10:1)
-createH5Attribute(h5, "d", c("jome?", "jeosfmdlmf", "s"))
+TH <- TestHarness()
+h5 <- H5File("test-read-points.h5", 'w')
-d <- createH5Dataset(h5, "jim", cbind(c('jime ', 'joe', 'mikey'),
- c('jime 2 ', 'joe 2', 'mikey 2')))
-d[]
+TH('create h5 attribute', {
+ createH5Attribute(h5, "e", 10:1)
+ all(getH5Attribute(h5, "e")[] == 10:1)
+})
-writeH5Data(d, c("johnson", "jodhsd"), c(1,0), c(2, 1))
+TH('create h5 attribute 2', {
+ strings <- c("ACGTACGT", "GGGGGGGGGGGGGGGG", "CCGCGCGCG")
+ createH5Attribute(h5, "d", strings)
+ all(getH5Attribute(h5, "d")[] == strings)
+})
-m <- createH5Dataset(h5, "mm", cbind(rnorm(1000), rnorm(1000)))
-m[1:10, 2]
-
+indta <- cbind(c(' xx ', '$$$$$$$$$$$', '||||'),
+ c(' jjjj', '"$"', '"""""""'))
-d1 <- createH5Dataset(h5, "jon", runif(100000))
-p <- readPoints(d1, ss <- sample(1:length(d1), size = 1000, replace = T))
-all(p == d1[ss])
+TH('create dataset', {
+ d <- createH5Dataset(h5, "d1", indta)
+ all(d[] == indta)
+})
+TH('write data', {
+ ndta <- cbind("yyy", "xxx")
+ writeH5Data(d, ndta, c(1,1), dim(ndta))
+ indta[1,] <- ndta
+ all(getH5Dataset(h5, "d1")[] == indta)
+})
-d2 <- createH5Dataset(h5, "jodf", paste(runif(200010)))
-d2[sample(1:length(d2), size = 1000)]
+TH('read points', {
+ d1 <- createH5Dataset(h5, "d3", runif(100000))
+ p <- readPoints(d1, ss <- sample(1:length(d1), size = 1000, replace = T))
+ all(p == d1[ss])
+})
+
+TH(action = 'print')
+TH(action = 'throw')
Modified: tests/testWrite.R
===================================================================
--- tests/testWrite.R 2013-07-02 20:14:29 UTC (rev 95)
+++ tests/testWrite.R 2013-07-08 21:52:52 UTC (rev 96)
@@ -73,5 +73,29 @@
deleteH5Attribute(g1, "jim")
})
+gt <- createH5Group(h5, "grp-type")
+
+TH("dataset type create 1", {
+ d <- createH5Dataset(gt, "d-type-1", matrix(rnorm(200, 100, sd = 10), ncol = 10), dType = "integer",
+ chunk = c(10, 10))
+ dd <- getH5Dataset(gt, "d-type-1")
+ all(dim(dd) == c(20, 10)) && storage.mode(dd[]) == 'integer'
+})
+
+TH("dataset type create 2", {
+ d <- createH5Dataset(gt, "d-type-2", rnorm(200, 100, sd = 10), dType = "integer",
+ dim = c(10, 20), chunk = c(10, 10))
+ dd <- getH5Dataset(gt, "d-type-2")
+ all(dim(dd) == c(10, 20)) && storage.mode(dd[]) == 'integer'
+})
+
+TH("dataset type 3", {
+ d <- createH5Dataset(gt, "d-type-3", rnorm(200, 100, sd = 10), dType = "character",
+ dim = c(10, 20), chunk = c(10, 10))
+ dd <- getH5Dataset(gt, "d-type-3")
+ all(dim(dd) == c(10, 20)) && storage.mode(dd[]) == 'character'
+})
+
TH(action = 'print')
+TH(action = 'throw')
More information about the H5r-commits
mailing list