Nothing
tests/RNetCDF-test.R
In RNetCDF: Interface to 'NetCDF' Datasets
#===============================================================================#
#
# Name: RNetCDF-test.R
#
# Version: 2.8-1
#
# Purpose: Test functions to the NetCDF interface for R.
#
# Author: Pavel Michna (rnetcdf-devel@bluewin.ch)
# Milton Woods (miltonjwoods@gmail.com)
#
# Copyright (C) 2004-2023 Pavel Michna and Milton Woods.
#
#===============================================================================#
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
#===============================================================================#
# Fail on warnings:
options(warn=2)
# tools::assertWarning is not defined in old R versions,
# so define a local function with similar behaviour:
assertWarning <- function(expr) {
warn <- FALSE
withCallingHandlers(expr,
warning=function(w) {
warn <<- TRUE
invokeRestart("muffleWarning")
}
)
if (!warn) {
stop("Expected warning from expression, but none occurred")
}
}
#===============================================================================#
# Load library
#===============================================================================#
library(RNetCDF)
has_bit64 <- require(bit64)
loadNamespace("tools")
#===============================================================================#
# Optional NetCDF features detected during package installation.
# Note that config.nc is not intended for user code.
# If necessary, users can handle missing features using 'try'.
#===============================================================================#
cfg <- config.nc()
#===============================================================================#
# Run tests
#===============================================================================#
#-------------------------------------------------------------------------------#
# NetCDF library functions
#-------------------------------------------------------------------------------#
#--Initialize ------------------------------------------------------------------#
cat("Starting NetCDF tests...\n")
testfun <- function(x,y,tally=NULL) {
if (is.null(tally)) {
tally <- c(pass=0,fail=0)
}
# Compare numeric values with single precision tolerance:
if (isTRUE(all.equal(x,y,tolerance=2^(-23)))) {
cat("OK\n")
return(tally+c(1,0))
} else {
cat("Failed\n")
cat("x:\n")
str(x)
print(attributes(x))
cat("y:\n")
str(y)
print(attributes(y))
return(tally+c(0,1))
}
}
tally <- NULL
## Create a new NetCDF dataset and define dimensions
for (format in c("classic","offset64","data64","classic4","netcdf4")) {
ncfile <- tempfile(paste("RNetCDF-test", format, "", sep="_"),
fileext=".nc")
cat("Test", format, "file format in", ncfile, "...\n")
if (format == "data64" && !cfg$data64) {
message("NetCDF library does not support file format data64")
nc <- try(create.nc(ncfile, format=format), silent=TRUE)
tally <- testfun(inherits(nc, "try-error"), TRUE, tally)
unlink(ncfile)
next
}
nc <- create.nc(ncfile, format=format)
tally <- testfun(TRUE, TRUE, tally)
# Show library version:
libvers <- file.inq.nc(nc)$libvers
cat("Version of netcdf library ... ", libvers, "\n")
verstr <- sub(' .*', '', file.inq.nc(nc)$libvers)
nstation <- 5
ntime <- 2
nstring <- 7
nempty <- 0
cat("Defining dimensions ...\n")
dim.def.nc(nc, "station", nstation)
dim.def.nc(nc, "time", ntime)
dim.def.nc(nc, "max_string_length", nstring)
dim.def.nc(nc, "empty", unlim=TRUE)
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
## Define a group
cat("Defining a group ...\n")
ncroot <- nc
nc <- grp.def.nc(nc, "testgrp")
tally <- testfun(TRUE, TRUE, tally)
## Define a type of each class:
cat("Defining user-defined types ...\n")
id_blob <- type.def.nc(nc, "blob", "opaque", size=128)
inq_blob <- list(id=id_blob, name="blob", class="opaque", size=128)
id_vector <- type.def.nc(nc, "vector", "vlen", basetype="NC_INT")
inq_vector <- list(id=id_vector, name="vector", class="vlen",
size=NA, basetype="NC_INT")
id_vector_char <- type.def.nc(nc, "vector_char", "vlen", basetype="NC_CHAR")
inq_vector_char <- list(id=id_vector_char, name="vector_char", class="vlen",
size=NA, basetype="NC_CHAR")
id_vector_string <- type.def.nc(nc, "vector_string", "vlen", basetype="NC_STRING")
inq_vector_string <- list(id=id_vector_string, name="vector_string", class="vlen",
size=NA, basetype="NC_STRING")
id_vector_blob <- type.def.nc(nc, "vector_blob", "vlen", basetype=id_blob)
inq_vector_blob <- list(id=id_vector_blob, name="vector_blob", class="vlen",
size=NA, basetype="blob")
id_factor <- type.def.nc(nc, "factor", "enum", basetype="NC_USHORT",
names=c("NA", "peanut butter", "jelly"),
values=c(100, 101, 102))
inq_factor <- list(id=id_factor, name="factor", class="enum",
size=2, basetype="NC_USHORT",
value=c("NA"=100,"peanut butter"=101,"jelly"=102))
id_struct <- type.def.nc(nc, "struct", "compound",
names=c("siteid", "height", "colour"),
subtypes=c("NC_INT", "NC_DOUBLE", "NC_SHORT"),
dimsizes=list(NULL, NULL, c(3)))
inq_struct <- list(id=id_struct, name="struct", class="compound", size=18,
offset=c(siteid=0,height=4,colour=12),
subtype=c(siteid="NC_INT",height="NC_DOUBLE",colour="NC_SHORT"),
dimsizes=list("siteid"=NULL,"height"=NULL,"colour"=c(3)))
typeids <- c(id_blob, id_vector, id_vector_char, id_vector_string,
id_vector_blob, id_factor, id_struct)
if (package_version(verstr) >= package_version("4.9.0")) {
id_vector_vector <- type.def.nc(nc, "vector_vector", "vlen", basetype=id_vector)
inq_vector_vector <- list(id=id_vector_vector, name="vector_vector", class="vlen",
size=NA, basetype="vector")
typeids <- c(typeids, id_vector_vector)
}
tally <- testfun(TRUE, TRUE, tally)
}
## Define variables
cat("Defining variables for netcdf3 ...\n")
var.def.nc(nc, "time", "NC_INT", "time")
inq_temperature <- list()
inq_temperature$id <- var.def.nc(nc, "temperature", "NC_DOUBLE", c(0,1),
chunking=TRUE, chunksizes=c(5,1),
deflate=5, shuffle=TRUE, big_endian=TRUE,
fletcher32=TRUE)
inq_temperature$name <- "temperature"
inq_temperature$type <- "NC_DOUBLE"
inq_temperature$ndims <- as.integer(2)
inq_temperature$dimids <- as.integer(c(0,1))
inq_temperature$natts <- as.integer(0)
inq_temperature$chunksizes <- as.numeric(c(5,1))
inq_temperature$deflate <- as.integer(5)
inq_temperature$shuffle <- TRUE
inq_temperature$big_endian <- TRUE
inq_temperature$fletcher32 <- TRUE
var.def.nc(nc, "packvar", "NC_BYTE", c("station"))
var.def.nc(nc, "name", "NC_CHAR", c("max_string_length", "station"))
var.def.nc(nc, "name_fill", "NC_CHAR", c("max_string_length", "station"))
var.def.nc(nc, "qcflag", "NC_CHAR", c("station"))
var.def.nc(nc, "int0", "NC_INT", NA)
var.def.nc(nc, "char0", "NC_CHAR", NA)
var.def.nc(nc, "numempty", "NC_FLOAT", c("station","empty"))
varcnt <- 9
numtypes <- c("NC_BYTE", "NC_SHORT", "NC_INT", "NC_FLOAT", "NC_DOUBLE")
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Defining variables for netcdf4 ...\n")
var.def.nc(nc, "namestr", "NC_STRING", c("station"))
var.def.nc(nc, "namestr_fill", "NC_STRING", c("station"))
var.def.nc(nc, "profile", id_vector, c("station","time"))
var.def.nc(nc, "profile_fill", id_vector, c("station","time"))
var.def.nc(nc, "profile_pack", id_vector, c("station","time"))
att.put.nc(nc, "profile_pack", "scale_factor", "NC_FLOAT", 10)
var.def.nc(nc, "profile_char", id_vector_char, c("station","time"))
var.def.nc(nc, "profile_string", id_vector_string, c("station","time"))
var.def.nc(nc, "profile_blob", id_vector_blob, c("time"))
var.def.nc(nc, "profile_scalar", id_vector, NA)
var.def.nc(nc, "rawdata", id_blob, c("station","time"))
var.def.nc(nc, "rawdata_scalar", id_blob, NA)
var.def.nc(nc, "rawdata_vector", id_blob, c("station"))
var.def.nc(nc, "snacks", "factor", c("station", "time"))
var.def.nc(nc, "snacks_empty", "factor", c("station", "time"))
var.def.nc(nc, "person", "struct", c("station", "time"))
var.def.nc(nc, "person_fill", "struct", c("station", "time"))
varcnt <- varcnt+16
if (package_version(verstr) >= package_version("4.9.0")) {
var.def.nc(nc, "profile_vector", id_vector_vector, c("station","time"))
var.def.nc(nc, "profile_vector_fill", id_vector_vector, c("station","time"))
varcnt <- varcnt+2
}
tally <- testfun(TRUE, TRUE, tally)
numtypes <- c(numtypes, "NC_UBYTE", "NC_USHORT", "NC_UINT")
if (has_bit64) {
var.def.nc(nc, "stationid", "NC_UINT64", c("station"))
varcnt <- varcnt+1
numtypes <- c(numtypes, "NC_INT64", "NC_UINT64")
tally <- testfun(TRUE, TRUE, tally)
}
inq_filter <- list()
inq_filter$filter_id <- c(2,1) # Shuffle, deflate
inq_filter$filter_params <- list(numeric(0),c(9))
var.def.nc(nc, "temp_filter", "NC_FLOAT", c("station", "time"),
chunking=TRUE, filter_id=inq_filter$filter_id,
filter_params=inq_filter$filter_params)
varcnt <- varcnt+1
}
for (numtype in numtypes) {
for (namode in seq(0,5)) {
cat("Defining variables of type", numtype, "for na.mode", namode, "...\n")
varname <- paste(numtype,namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"int",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"fill",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"intfill",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"pack",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"intpack",namode,sep="_")
var.def.nc(nc, varname, numtype, "station")
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"inf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"packinf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varname <- paste(numtype,"intpackinf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varcnt <- varcnt+9
if (numtype == "NC_DOUBLE") {
varname <- paste(numtype,"fillna",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, as.double(NA))
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(as.double(-Inf),as.double(Inf)))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, as.double(NA))
}
tally <- testfun(TRUE, TRUE, tally)
varcnt <- varcnt+1
}
if (numtype == "NC_INT") {
varname <- paste(numtype,"intfillna",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, as.integer(NA))
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, as.integer(NA))
}
tally <- testfun(TRUE, TRUE, tally)
varcnt <- varcnt+1
}
if (has_bit64) {
varname <- paste(numtype,"bit64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"fill64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"pack64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"packinf64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varcnt <- varcnt+4
}
}
}
cat("Defining additional attributes ...")
## Set a _FillValue attribute for temperature
att.put.nc(nc, "temperature", "_FillValue", "NC_DOUBLE", -99999.9)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
## Set a _FillValue attribute for name_fill:
att.put.nc(nc, "name_fill", "_FillValue", "NC_CHAR", "X")
## Define the packing used by packvar
id_double <- type.inq.nc(nc, "NC_DOUBLE")$id
att.put.nc(nc, "packvar", "scale_factor", id_double, 10)
att.put.nc(nc, "packvar", "add_offset", "NC_DOUBLE", -5)
## Define some additional test attributes:
att_text <- "This is some text"
att_text2 <- c("This is string 1", "This is string 2")
att.put.nc(nc, "NC_GLOBAL", "char_att", "NC_CHAR", att_text)
att.put.nc(nc, "name", "char_att", "NC_CHAR", att_text)
att.put.nc(nc, "name", "raw_att", "NC_CHAR", charToRaw(att_text))
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Defining additional attributes for netcdf4 ...")
att.put.nc(nc, "temperature", "string_att", "NC_STRING", att_text2)
tally <- testfun(TRUE, TRUE, tally)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
if (has_bit64) {
hugeint <- as.integer64("-1234567890123456789")
att.put.nc(nc, "temperature", "int64_att", "NC_INT64", hugeint)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
tally <- testfun(TRUE, TRUE, tally)
}
}
## Define variable values
mytime <- c(1:2)
mytemperature <- matrix(c(1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, NA, NA, 9.9),ncol=ntime)
mypackvar <- seq_len(5)*10-5
myname <- c("alfa", "bravo", "charlie", "delta", "echo")
myqcflag <- "ABCDE"
myint0 <- 12345
mychar0 <- "?"
mynamefill <- myname
for (ii in seq_along(myname)) {
mynamefill[ii] <- paste(rep("X", nstring), collapse="")
substr(mynamefill[ii], 1, nstring) <- myname[ii]
}
mynamestr <- myname
mynamestr[5] <- "NA"
mynamestr_fill <- myname
mynamestr_fill[5] <- NA
mysmall <- as.double(c(1,2,3,4,5))
mybig <- mysmall*1e100
myminus <- -mysmall
mysmallfill <- as.double(c(1,2,NA,4,5))
mybigfill <- mysmallfill*1e100
mypack <- mysmallfill*10+5
myinffill <- c(-Inf,.Machine$double.xmin,NA,NaN,Inf)
myinf <- c(1,2,-Inf,4,5)
if (has_bit64) {
mysmall64 <- as.integer64(mysmall)
mysmallfill64 <- as.integer64(mysmallfill)
myminus64 <- -mysmall64
mybig64 <- as.integer64("1234567890123456789")+mysmall
mybigfill64 <- as.integer64("1234567890123456789")+mysmallfill
mypack64 <- as.integer64(mypack)
}
if (format == "netcdf4") {
profiles <- vector("list", nstation*ntime)
dim(profiles) <- c(nstation, ntime)
for (ii in seq_len(nstation)) {
for (jj in seq_len(ntime)) {
# Profiles have increasing length, starting from 0:
profiles[[ii,jj]] <- 10*seq_len(ii+jj-2)*(ii+jj)
}
}
profiles_char <- lapply(profiles,function(x) {paste(as.character(x),collapse=",")})
dim(profiles_char) <- dim(profiles)
profiles_string <- lapply(profiles, as.character)
dim(profiles_string) <- dim(profiles)
if (package_version(verstr) >= package_version("4.9.0")) {
profiles_vector <- lapply(profiles, function(x) {lapply(x, seq_len)})
dim(profiles_vector) <- dim(profiles)
profiles_vector_fill <- profiles_vector
profiles_vector_fillval <- list(list(-999999999))
profiles_vector[[3]][[2]][5] <- -999999999
profiles_vector_fill[[3]][[2]][5] <- NA
}
profiles_fill <- profiles
profiles_fillval <- list(-999999999)
profiles[[3]][2] <- -999999999
profiles_fill[[3]][2] <- NA
rawdata <- as.raw(seq_len(nstation*ntime*128) %% 256)
dim(rawdata) <- c(128,nstation,ntime)
profiles_blob <- list(rawdata[,3:5,1], rawdata[,0,1])
dim(profiles_blob) <- ntime
snack_foods <- names(inq_factor$value)
snacks <- factor(rep(snack_foods, length.out=nstation*ntime),
levels=snack_foods)
dim(snacks) <- c(nstation, ntime)
snacks_fill <- snacks
snacks_fill[snacks_fill == "NA"] <- NA
snacks_empty <- snacks
snacks_empty[] <- NA
person <- list(siteid=array(rep(seq(1,nstation),ntime), c(nstation,ntime)),
height=array(1+0.1*seq(1,nstation*ntime), c(nstation,ntime)),
colour=array(rep(c(0,0,0,64,128,192),nstation), c(3,nstation,ntime)))
person_fillval <- list(siteid=person$siteid[1,1],
height=person$height[1,1],
colour=person$colour[,1,1])
person_fill <- person
person_fill$siteid[person_fill$siteid == person_fillval$siteid] <- NA
person_fill$height[person_fill$height == person_fillval$height] <- NA
# Note that array in compound uses same fill value for all elements:
person_fill$colour[person_fill$colour == person_fillval$colour[1]] <- NA
}
## Define some user-defined test attributes:
if (format == "netcdf4") {
cat("Defining user-defined attributes ...")
person1 <- list(siteid=array(person$siteid[1,1], 1),
height=array(person$height[1,1], 1),
colour=array(person$colour[,1,1], c(3,1)))
person3 <- list(siteid=array(person$siteid[1:3,1], 3),
height=array(person$height[1:3,1], 3),
colour=array(person$colour[,1:3,1], c(3,3)))
att.put.nc(nc, "NC_GLOBAL", "compound_scal_att", "struct", person1)
att.put.nc(nc, "NC_GLOBAL", "compound_vect_att", "struct", person3)
att.put.nc(nc, "NC_GLOBAL", "enum_scal_att", "factor", snacks[1])
att.put.nc(nc, "NC_GLOBAL", "enum_vect_att", "factor", snacks[1:3])
att.put.nc(nc, "NC_GLOBAL", "opaque_scal_att", "blob", rawdata[,1,1])
att.put.nc(nc, "NC_GLOBAL", "opaque_vect_att", "blob", rawdata[,1,])
att.put.nc(nc, "NC_GLOBAL", "vector_scal_att", "vector", profiles[1])
att.put.nc(nc, "NC_GLOBAL", "vector_vect_att", "vector", profiles[1:3])
tally <- testfun(TRUE, TRUE, tally)
# Fill values for strings and user-defined variables:
att.put.nc(nc, "namestr_fill", "_FillValue", "NC_STRING", "_MISSING")
att.put.nc(nc, "snacks", "_FillValue", "factor", factor("NA"))
att.put.nc(nc, "person_fill", "_FillValue", "struct", person_fillval)
att.put.nc(nc, "profile_fill", "_FillValue", id_vector,
profiles_fillval)
if (package_version(verstr) >= package_version("4.9.0")) {
att.put.nc(nc, "profile_vector_fill", "_FillValue", id_vector_vector,
profiles_vector_fillval)
}
}
## Put the data
cat("Writing netcdf3 variables ...")
var.put.nc(nc, "time", mytime, 1, length(mytime))
var.put.nc(nc, "temperature", mytemperature, c(1,1), c(nstation,ntime),
cache_preemption=0.5)
var.put.nc(nc, "packvar", mypackvar, pack=TRUE)
var.put.nc(nc, "name", myname, c(1,1), c(nstring,nstation))
var.put.nc(nc, "name_fill", myname, na.mode=5)
var.put.nc(nc, "qcflag", charToRaw(myqcflag))
var.put.nc(nc, "int0", myint0)
var.put.nc(nc, "char0", mychar0)
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Writing extra netcdf4 variables ...")
var.put.nc(nc, "namestr", mynamestr_fill)
var.put.nc(nc, "namestr_fill", mynamestr_fill, na.mode=5)
var.put.nc(nc, "profile", profiles)
var.put.nc(nc, "profile_fill", profiles_fill, na.mode=5)
var.put.nc(nc, "profile_pack", profiles, pack=TRUE)
var.put.nc(nc, "profile_char", profiles_char)
var.put.nc(nc, "profile_string", profiles_string)
var.put.nc(nc, "profile_blob", profiles_blob)
var.put.nc(nc, "profile_scalar", profiles[1])
var.put.nc(nc, "rawdata", rawdata)
var.put.nc(nc, "rawdata_scalar", rawdata[,1,1])
var.put.nc(nc, "rawdata_vector", rawdata[,,1])
if (package_version(verstr) >= package_version("4.9.0")) {
var.put.nc(nc, "profile_vector", profiles_vector)
var.put.nc(nc, "profile_vector_fill", profiles_vector_fill, na.mode=5)
}
y <- try(var.put.nc(nc, "snacks", snacks_fill, na.mode=3), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
var.put.nc(nc, "snacks", snacks_fill, na.mode=5)
tally <- testfun(TRUE, TRUE, tally)
var.put.nc(nc, "person", person, na.mode=3)
tally <- testfun(TRUE, TRUE, tally)
var.put.nc(nc, "person_fill", person_fill, na.mode=5)
tally <- testfun(TRUE, TRUE, tally)
if (has_bit64) {
var.put.nc(nc, "stationid", mybig64)
tally <- testfun(TRUE, TRUE, tally)
}
var.put.nc(nc, "temp_filter", mytemperature)
tally <- testfun(TRUE, TRUE, tally)
}
for (numtype in numtypes) {
for (namode in seq(0,5)) {
cat("Writing to variable type", numtype, "with na.mode", namode, "...\n")
# Should not succeed except for NC_DOUBLE:
cat("Writing huge values ...")
y <- try(var.put.nc(nc, paste(numtype,namode,sep="_"), mybig, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype!="NC_DOUBLE", tally)
y <- try(var.put.nc(nc, paste(numtype,"fill",namode,sep="_"), mybigfill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype!="NC_DOUBLE", tally)
# Should not succeed except for NC_FLOAT and 64-bit types:
if (has_bit64) {
cat("Writing huge bit64 values ...")
y <- try(var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), mybig64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), !(numtype %in% c("NC_FLOAT","NC_INT64","NC_UINT64","NC_DOUBLE")), tally)
}
# Should not succeed for unsigned types:
cat("Writing negative values ...")
y <- try(var.put.nc(nc, paste(numtype,namode,sep="_"), myminus, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"),
any(numtype==c("NC_UBYTE", "NC_USHORT", "NC_UINT", "NC_UINT64")),
tally)
# Allow wrapping of negative bit64 values when converting to NC_UINT64:
if (has_bit64) {
cat("Writing negative bit64 values ...")
y <- try(var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), myminus64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype %in% c("NC_UBYTE","NC_USHORT","NC_UINT"), tally)
}
# Should succeed for all types:
cat("Writing data without missing values ...")
var.put.nc(nc, paste(numtype,namode,sep="_"), mysmall, na.mode=namode)
var.put.nc(nc, paste(numtype,"int",namode,sep="_"), as.integer(mysmall), na.mode=namode)
tally <- testfun(TRUE, TRUE, tally)
if (has_bit64) {
cat("Writing bit64 data without missing values ...")
var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), mysmall64, na.mode=namode)
tally <- testfun(TRUE, TRUE, tally)
}
# Should succeed except in the following cases:
inffail <- !(numtype %in% c("NC_FLOAT","NC_DOUBLE"))
nafail <- (namode==3 && !(numtype %in% c("NC_FLOAT","NC_DOUBLE")))
naintfail <- (namode==3 && !(numtype %in% c("NC_INT","NC_INT64","NC_FLOAT","NC_DOUBLE")))
nabit64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_UINT64","NC_FLOAT","NC_DOUBLE")))
napack64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_FLOAT","NC_DOUBLE")))
cat("Writing Inf values ...")
y <- try(var.put.nc(nc, paste(numtype,"inf",namode,sep="_"), myinf, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing doubles with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"packinf",namode,sep="_"), mypack, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing integers with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"intpackinf",namode,sep="_"), as.integer(mypack), pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing data with missing values ...")
y <- try(var.put.nc(nc, paste(numtype,"fill",namode,sep="_"), mysmallfill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
y <- try(var.put.nc(nc, paste(numtype,"intfill",namode,sep="_"), as.integer(mysmallfill), na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
if (numtype == "NC_INT") {
cat("Writing data with missing values and NA fill ...")
y <- try(var.put.nc(nc, paste(numtype,"intfillna",namode,sep="_"), as.integer(mysmallfill), na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
} else if (numtype == "NC_DOUBLE") {
cat("Writing data with non-finite values and NA fill ...")
y <- try(var.put.nc(nc, paste(numtype,"fillna",namode,sep="_"), myinffill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
}
cat("Writing data with missing values and packing ...")
y <- try(var.put.nc(nc, paste(numtype,"pack",namode,sep="_"), mypack, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
y <- try(var.put.nc(nc, paste(numtype,"intpack",namode,sep="_"), as.integer(mypack), pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
if (has_bit64) {
cat("Writing bit64 data with missing values ...")
y <- try(var.put.nc(nc, paste(numtype,"fill64",namode,sep="_"), mysmallfill64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nabit64fail, tally)
cat("Writing bit64 data with missing values and packing ...")
y <- try(var.put.nc(nc, paste(numtype,"pack64",namode,sep="_"), mypack64, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), napack64fail, tally)
cat("Writing integer64 with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"packinf64",namode,sep="_"), mypack64, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
}
}
}
if (format == "netcdf4") {
# Check chunk cache settings for temperature:
cat("Check chunk cache settings after writing temperature ...")
x <- var.inq.nc(nc, "temperature")$cache_preemption
if (is.na(x)) {
cat("Feature not available in this NetCDF library version.\n")
} else {
y <- 0.5
tally <- testfun(x,y,tally)
}
# Check multi-filter inquiry:
cat("Check filter settings after writing temp_filter ...")
x <- var.inq.nc(nc, "temp_filter")
if (is.null(x$filter_id) && is.null(x$filter_params)) {
cat("Multi-filters not available in this NetCDF library version.\n")
} else {
tally <- testfun(x[names(inq_filter)], inq_filter, tally)
}
}
# sync.nc(nc)
if (format == "netcdf4") {
close.nc(ncroot)
ncroot <- open.nc(ncfile)
nc <- grp.inq.nc(ncroot, "testgrp")$self
} else {
close.nc(nc)
nc <- open.nc(ncfile)
}
cat("Check file format ...")
x <- file.inq.nc(nc)$format
y <- format
tally <- testfun(x,y,tally)
## Display file structure
print.nc(nc)
## Read tests
cat("Read NC_CHAR global attribute ...")
x <- att_text
y <- att.get.nc(nc, "NC_GLOBAL", "char_att")
tally <- testfun(x,y,tally)
cat("Read NC_CHAR variable attribute ...")
x <- att_text
y <- att.get.nc(nc, "name", "char_att")
tally <- testfun(x,y,tally)
cat("Read NC_CHAR variable attribute as raw bytes ...")
x <- charToRaw(att_text)
y <- att.get.nc(nc, "name", "raw_att", rawchar=TRUE)
tally <- testfun(x,y,tally)
if (format == "netcdf4") {
cat("Read NC_STRING variable attribute ...")
x <- att_text2
y <- att.get.nc(nc, "temperature", "string_att")
tally <- testfun(x,y,tally)
if (has_bit64) {
cat("Read NC_INT64 variable attribute ...")
x <- hugeint
y <- att.get.nc(nc, "temperature", "int64_att", fitnum=TRUE)
tally <- testfun(x,y,tally)
cat("Read NC_INT64 variable attribute as numeric ...")
x <- suppressWarnings(as.numeric(hugeint))
y <- att.get.nc(nc, "temperature", "int64_att")
tally <- testfun(x,y,tally)
}
}
grpinfo <- grp.inq.nc(nc)
cat("Inquire about groups in file/group ...")
tally <- testfun(grpinfo$grps,list(),tally)
cat("Inquire about dimension ids in file/group ...")
tally <- testfun(grpinfo$dimids,c(0:3),tally)
cat("Inquire about variable ids in file/group ...")
tally <- testfun(grpinfo$varids,c(0:(varcnt-1)),tally)
cat("Inquire about fullname of file/group ...")
if (format == "netcdf4") {
tally <- testfun(grpinfo$fullname,"/testgrp",tally)
} else {
tally <- testfun(grpinfo$fullname,"/",tally)
}
cat("Inquire about unlimited dimension ids of file/group ...")
if (format == "netcdf4") {
# Some versions of netcdf4 do not list unlimited dimensions in ancestor groups:
if (length(grpinfo$unlimids)==0) {
tally <- testfun(grpinfo$unlimids,integer(0),tally)
} else {
tally <- testfun(grpinfo$unlimids,3,tally)
}
} else {
tally <- testfun(grpinfo$unlimids,3,tally)
}
if (format == "netcdf4") {
cat("Inquire about user-defined types in file/group ...")
tally <- testfun(grpinfo$typeids,typeids,tally)
}
cat("Read integer vector as double ... ")
x <- mytime
dim(x) <- length(x)
y <- var.get.nc(nc, 0)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
for (numtype in numtypes) {
for (namode in seq(0,5)) {
x <- mysmall
dim(x) <- length(x)
varname <- paste(numtype,namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
varname <- paste(numtype,"int",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
if (has_bit64) {
varname <- paste(numtype,"bit64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
# Some cases are expected to fail when writing the data,
# so there is nothing to read:
nafail <- (namode==3 && numtype != "NC_DOUBLE")
naintfail <- (namode==3 && !(numtype %in% c("NC_INT","NC_INT64","NC_FLOAT","NC_DOUBLE")))
nabit64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_FLOAT","NC_DOUBLE")))
x <- mysmallfill
dim(x) <- length(x)
if (!nafail) {
varname <- paste(numtype,"fill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
if (!naintfail) {
varname <- paste(numtype,"intfill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (has_bit64 && !nabit64fail) {
varname <- paste(numtype,"fill64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (numtype == "NC_INT" && !naintfail) {
x <- mysmallfill
dim(x) <- length(x)
varname <- paste(numtype,"intfillna",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
} else if (numtype == "NC_DOUBLE" && !nafail) {
x <- myinffill
dim(x) <- length(x)
varname <- paste(numtype,"fillna",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
x <- mypack
dim(x) <- length(x)
if (!nafail) {
varname <- paste(numtype,"pack",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
if (!naintfail) {
varname <- paste(numtype,"intpack",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (has_bit64 && !nabit64fail) {
varname <- paste(numtype,"pack64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
}
}
cat("Read integer vector as smallest R type ... ")
x <- mytime
dim(x) <- length(x)
y <- var.get.nc(nc, 0, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),TRUE,tally)
for (numtype in numtypes) {
x <- mysmall
if (has_bit64 && any(numtype==c("NC_INT64","NC_UINT64"))) {
x <- as.integer64(x)
}
dim(x) <- length(x)
varname <- paste(numtype,namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),
any(numtype==c("NC_BYTE","NC_UBYTE","NC_SHORT","NC_USHORT","NC_INT")),
tally)
x <- mysmallfill
if (has_bit64 && any(numtype==c("NC_INT64","NC_UINT64"))) {
x <- as.integer64(x)
}
dim(x) <- length(x)
varname <- paste(numtype,"fill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),
any(numtype==c("NC_BYTE","NC_UBYTE","NC_SHORT","NC_USHORT","NC_INT")),
tally)
}
cat("Read numeric matrix ... ")
x <- mytemperature
y <- var.get.nc(nc, "temperature", cache_preemption=0.4)
tally <- testfun(x,y,tally)
cat("Inquire about numeric variable ...")
x <- inq_temperature
y <- var.inq.nc(nc, "temperature")
var_inq_names <- c("id", "name", "type", "ndims", "dimids", "natts")
if (format == "netcdf4") {
var_inq_names_nc4 <- c(var_inq_names, "chunksizes", "deflate", "shuffle",
"fletcher32")
tally <- testfun(x[var_inq_names_nc4], y[var_inq_names_nc4], tally)
big_endian <- y$big_endian
# May be NULL or NA for older netcdf libraries, TRUE otherwise.
if (!is.null(big_endian) && !isTRUE(is.na(big_endian))) {
tally <- testfun(TRUE, big_endian, tally)
}
preempt <- y$cache_preemption
# May be NULL for older netcdf libraries, numeric otherwise.
if (!is.null(preempt)) {
tally <- testfun(0.4, preempt, tally)
}
} else {
tally <- testfun(x[var_inq_names], y[var_inq_names], tally)
}
cat("Read numeric matrix slice ... ")
x <- mytemperature[,2,drop=FALSE]
y <- var.get.nc(nc, "temperature", c(NA,2), c(NA,1), collapse=FALSE)
tally <- testfun(x,y,tally)
x <- mytemperature[,2]
y <- var.get.nc(nc, "temperature", c(NA,2), c(NA,1), collapse=TRUE)
tally <- testfun(x,y,tally)
cat("Read numeric matrix empty slice ... ")
x <- numeric(0)
dim(x) <- c(0,1)
y <- var.get.nc(nc, "temperature", c(NA,2), c(0,1), collapse=FALSE)
tally <- testfun(x,y,tally)
y <- var.get.nc(nc, "temperature", c(NA,2), c(0,1), collapse=TRUE)
tally <- testfun(drop(x),y,tally)
cat("Read numeric scalar ... ")
x <- myint0
y <- var.get.nc(nc, "int0")
tally <- testfun(x,y,tally)
cat("Read numeric empty array ... ")
x <- numeric(0)
dim(x) <- c(nstation,nempty)
y <- var.get.nc(nc, "numempty")
tally <- testfun(x,y,tally)
cat("Read 2D char array ... ")
x <- myname
dim(x) <- length(x)
y <- var.get.nc(nc, "name")
tally <- testfun(x,y,tally)
cat("Read 2D char array with fill value ... ")
x <- mynamefill
dim(x) <- length(x)
y <- var.get.nc(nc, "name_fill", na.mode=3)
tally <- testfun(x,y,tally)
x <- myname
dim(x) <- length(x)
y <- var.get.nc(nc, "name_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read 2D char slice ... ")
x <- substring(myname[2:3],1,4)
dim(x) <- length(x)
y <- var.get.nc(nc, "name", c(1,2), c(4,2))
tally <- testfun(x,y,tally)
cat("Read 2D char slice as raw bytes ... ")
x <- substring(myname[2:3],1,4)
dim(x) <- length(x)
x <- apply(x,MARGIN=1,FUN=charToRaw)
y <- var.get.nc(nc, "name", c(1,2), c(4,2), rawchar=TRUE)
tally <- testfun(x,y,tally)
cat("Read 2D char slice as characters ... ")
x <- myname[2:3]
dim(x) <- length(x)
y <- var.get.nc(nc, "name", c(1,2), c(NA,2))
tally <- testfun(x,y,tally)
cat("Read empty 2D char array ... ")
x <- character(0)
dim(x) <- 0
y <- var.get.nc(nc, "name", NA, c(0,0), collapse=FALSE)
tally <- testfun(x,y,tally)
y <- var.get.nc(nc, "name", NA, c(0,0), collapse=TRUE)
tally <- testfun(drop(x),y,tally)
cat("Read 1D char slice ... ")
x <- substring(myqcflag,2,3)
y <- var.get.nc(nc, "qcflag", c(2), c(2))
tally <- testfun(x,y,tally)
cat("Read scalar char ... ")
x <- mychar0
y <- var.get.nc(nc, "char0")
tally <- testfun(x,y,tally)
if (format == "netcdf4") {
cat("Read 1D string array ...")
x <- mynamestr
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr")
tally <- testfun(x,y,tally)
cat("Read 1D string array with fill values ...")
x <- mynamestr_fill
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read 1D string slice ...")
x <- mynamestr[2:3]
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr", c(2), c(2))
tally <- testfun(x,y,tally)
if (has_bit64) {
cat("Read 1D int64 array as integer64 ...")
x <- mybig64
dim(x) <- length(x)
y <- var.get.nc(nc, "stationid", fitnum=TRUE)
tally <- testfun(x,y,tally)
}
cat("Read details of user-defined types ...")
x <- inq_blob
y <- type.inq.nc(nc, id_blob)
tally <- testfun(x,y,tally)
# Reported size may depend on netcdf version and pointer size:
x <- inq_vector[-4]
y <- type.inq.nc(nc, id_vector)[-4]
tally <- testfun(x,y,tally)
x <- inq_vector_char[-4]
y <- type.inq.nc(nc, id_vector_char)[-4]
tally <- testfun(x,y,tally)
x <- inq_vector_blob[-4]
y <- type.inq.nc(nc, id_vector_blob)[-4]
tally <- testfun(x,y,tally)
x <- inq_factor
y <- type.inq.nc(nc, id_factor)
tally <- testfun(x,y,tally)
x <- inq_factor[1:5]
y <- type.inq.nc(nc, id_factor, fields=FALSE)
tally <- testfun(x,y,tally)
# Size and offset of compound types may differ between writing and reading.
# The layout for writing (reading) is defined by the user (compiler).
x <- inq_struct[c(-4,-5)]
y <- type.inq.nc(nc, id_struct)[c(-4,-5)]
tally <- testfun(x,y,tally)
x <- inq_struct[1:3]
y <- type.inq.nc(nc, id_struct, fields=FALSE)[-4]
tally <- testfun(x,y,tally)
cat("Read vlen as double ...")
x <- profiles
y <- var.get.nc(nc, "profile")
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.double))), TRUE, tally)
cat("Read vlen as integer ...")
x <- profiles
y <- var.get.nc(nc, "profile", fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.integer))), TRUE, tally)
cat("Read vlen with fill ...")
x <- profiles_fill
y <- var.get.nc(nc, "profile_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read vlen scalar ...")
x <- profiles[1]
y <- var.get.nc(nc, "profile_scalar")
tally <- testfun(x,y,tally)
cat("Reading packed vlen ...")
x <- profiles
y <- var.get.nc(nc, "profile_pack", unpack=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.double))), TRUE, tally)
cat("Read character vlen ...")
x <- profiles_char
y <- var.get.nc(nc, "profile_char")
tally <- testfun(x,y,tally)
cat("Read character vlen as raw ...")
x <- lapply(profiles_char,charToRaw)
dim(x) <- dim(profiles_char)
y <- var.get.nc(nc, "profile_char", rawchar=TRUE)
tally <- testfun(x,y,tally)
cat("Read string vlen ...")
x <- profiles_string
y <- var.get.nc(nc, "profile_string")
tally <- testfun(x,y,tally)
if (package_version(verstr) >= package_version("4.9.0")) {
cat("Read nested vlen ...")
x <- profiles_vector
y <- var.get.nc(nc, "profile_vector", na.mode=3)
tally <- testfun(x,y,tally)
cat("Read nested vlen with fill ...")
x <- profiles_vector_fill
y <- var.get.nc(nc, "profile_vector_fill", na.mode=5)
tally <- testfun(x,y,tally)
}
cat("Read opaque ...")
x <- rawdata
y <- var.get.nc(nc, "rawdata")
tally <- testfun(x,y,tally)
cat("Read opaque scalar ...")
x <- rawdata[,1,1]
dim(x) <- length(x)
y <- var.get.nc(nc, "rawdata_scalar")
tally <- testfun(x,y,tally)
cat("Read opaque vector ...")
x <- rawdata[,,1]
y <- var.get.nc(nc, "rawdata_vector")
tally <- testfun(x,y,tally)
cat("Read opaque vlen ...")
x <- profiles_blob
y <- var.get.nc(nc, "profile_blob")
tally <- testfun(x,y,tally)
cat("Read enum ...")
x <- snacks
y <- var.get.nc(nc, "snacks", na.mode=3)
tally <- testfun(x,y,tally)
x <- snacks_fill
y <- var.get.nc(nc, "snacks", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read empty enum ...")
x <- snacks_empty
y <- NULL
assertWarning(y <- var.get.nc(nc, "snacks_empty"))
tally <- testfun(x,y,tally)
cat("Read compound ...")
x <- person
y <- var.get.nc(nc, "person", na.mode=3)
tally <- testfun(x,y,tally)
cat("Read compound with fill ...")
x <- person_fill
y <- var.get.nc(nc, "person_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read compound scalar attribute ...")
x <- person1
y <- att.get.nc(nc, "NC_GLOBAL", "compound_scal_att")
tally <- testfun(x,y,tally)
cat("Read compound vector attribute ...")
x <- person3
y <- att.get.nc(nc, "NC_GLOBAL", "compound_vect_att")
tally <- testfun(x,y,tally)
cat("Read enum scalar attribute ...")
x <- snacks[1]
y <- att.get.nc(nc, "NC_GLOBAL", "enum_scal_att")
tally <- testfun(x,y,tally)
cat("Read enum vector attribute ...")
x <- snacks[1:3]
y <- att.get.nc(nc, "NC_GLOBAL", "enum_vect_att")
tally <- testfun(x,y,tally)
cat("Read opaque scalar attribute ...")
x <- rawdata[,1,1]
dim(x) <- c(length(x),1)
y <- att.get.nc(nc, "NC_GLOBAL", "opaque_scal_att")
tally <- testfun(x,y,tally)
cat("Read opaque vector attribute ...")
x <- rawdata[,1,]
y <- att.get.nc(nc, "NC_GLOBAL", "opaque_vect_att")
tally <- testfun(x,y,tally)
cat("Read vlen scalar attribute ...")
x <- profiles[1]
y <- att.get.nc(nc, "NC_GLOBAL", "vector_scal_att")
tally <- testfun(x,y,tally)
cat("Read vlen vector attribute ...")
x <- profiles[1:3]
y <- att.get.nc(nc, "NC_GLOBAL", "vector_vect_att")
tally <- testfun(x,y,tally)
}
cat("Read and unpack numeric array ... ")
x <- mypackvar
dim(x) <- length(x)
y <- var.get.nc(nc, "packvar", unpack=TRUE)
tally <- testfun(x,y,tally)
cat("Check that closing any NetCDF handle closes the file for all handles ... ")
close.nc(nc)
y <- try(file.inq.nc(grpinfo$self), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
cat("Check that garbage collector closes file that is not referenced ... ")
attr(nc,"handle_ptr") <- NULL # NetCDF objects should not normally be modified
rm(grpinfo)
gc()
y <- try(file.inq.nc(nc), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
unlink(ncfile)
cat("Removed test file", ncfile, "\n")
}
# Try diskless files:
ncfile <- tempfile("RNetCDF-test-diskless", fileext=".nc")
cat("Test diskless creation of ", ncfile, "...\n")
if (cfg$diskless) {
nc <- create.nc(ncfile, diskless=TRUE)
tally <- testfun(file.exists(ncfile), FALSE, tally)
close.nc(nc)
} else {
message("NetCDF library does not support diskless datasets")
nc <- try(create.nc(ncfile, diskless=TRUE), silent=TRUE)
tally <- testfun(inherits(nc, "try-error"), TRUE, tally)
}
unlink(ncfile)
#-------------------------------------------------------------------------------#
# UDUNITS calendar functions
#-------------------------------------------------------------------------------#
# Test if udunits support is available:
if (!cfg$udunits) {
message("UDUNITS calendar conversions not supported by this build of RNetCDF")
x <- try(utcal.nc("seconds since 1970-01-01", 0), silent=TRUE)
tally <- testfun(inherits(x, "try-error"), TRUE, tally)
} else {
cat("utcal.nc - numeric values ...")
x <- matrix(data=c(1899, 1900, 1900, 1900, 1900, 1900,
12, 1, 1, 1, 1, 1,
31, 1, 1, 1, 1, 1,
23, 0, 1, 2, 3, 4,
0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0),
ncol=6)
colnames(x) <- c("year","month","day","hour","minute","second")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5))
tally <- testfun(x,y,tally)
cat("utcal.nc - string values ...")
x <- c("1899-12-31 23:00:00", "1900-01-01 00:00:00", "1900-01-01 01:00:00",
"1900-01-01 02:00:00", "1900-01-01 03:00:00", "1900-01-01 04:00:00")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5), type="s")
tally <- testfun(x,y,tally)
cat("utcal.nc - POSIXct values ...")
x <- ISOdatetime(c(1899,1900,1900,1900,1900,1900),
c( 12, 1, 1, 1, 1, 1),
c( 31, 1, 1, 1, 1, 1),
c( 23, 0, 1, 2, 3, 4),
c( 0, 0, 0, 0, 0, 0),
c( 0, 0, 0, 0, 0, 0), tz="UTC")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5), type="c")
tally <- testfun(x,y,tally)
cat("utinvcal.nc - numeric values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(1900,1,1,5,25,0))
tally <- testfun(x,y,tally)
cat("utinvcal.nc - string values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00", "1900-01-01 05:25:00")
tally <- testfun(x,y,tally)
cat("utinvcal.nc - POSIXct values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00",
ISOdatetime(1900,1,1,5,25,0,tz="UTC"))
tally <- testfun(x,y,tally)
}
#-------------------------------------------------------------------------------#
# Parallel I/O demos
#-------------------------------------------------------------------------------#
mpiexec <- cfg$mpiexec
parallel <- cfg$parallel
if (mpiexec != "") {
# mpiexec is specified, so assume that parallel I/O is meant to be enabled.
# List of MPI packages to test:
mpipkgs <- c("Rmpi", "pbdMPI")
# Try to find demo script directory:
demodirs <- c("demo",
file.path("..", "demo"),
file.path("..", "RNetCDF", "demo"))
demodir <- demodirs[dir.exists(demodirs)]
stopifnot(length(demodir) > 0)
# Check if any of the packages are loaded:
for (mpipkg in mpipkgs) {
if (isNamespaceLoaded(mpipkg)) {
warning("Package ", mpipkg, " is loaded, so mpiexec may fail")
}
}
for (mpipkg in c("Rmpi", "pbdMPI")) {
# We cannot use requireNamespace to check for installed MPI packages,
# because they may initialise the MPI library via .onLoad,
# which causes failure when we try to mpiexec another R script.
if (length(find.package(mpipkg, quiet=TRUE) > 0)) {
cat("Testing parallel I/O with package", mpipkg, "...\n")
demoscripts <- list.files(
demodir,
pattern=paste0(mpipkg, ".*\\.R"),
full.names=TRUE)
stopifnot(length(demoscripts) >= 1)
for (demoscript in demoscripts) {
ncfile <- tempfile("RNetCDF-MPI-test", fileext=".nc")
cat("Running script", demoscript, "with MPI ...\n")
x <- system2(mpiexec,
args=c('-n', '2', 'Rscript', '--vanilla', demoscript, ncfile))
unlink(ncfile)
tally <- testfun(x, 0, tally)
}
} else {
message("Package ", mpipkg, " not available for parallel I/O tests\n")
}
}
} else if (parallel) {
# Parallel I/O may be enabled, but we cannot test without mpiexec being specified.
cat("Skipping parallel I/O tests as mpiexec is not defined\n")
} else {
# Assume that parallel I/O is meant to be disabled,
# because parallel is FALSE and mpiexec is not specified.
ncfile <- tempfile("RNetCDF-MPI-test", fileext=".nc")
cat("Testing that create.nc fails with mpi_comm ... ")
x <- try(create.nc(ncfile, format="netcdf4", mpi_comm=1), silent=TRUE)
unlink(ncfile)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
cat("Testing that open.nc fails with mpi_comm ... ")
x <- try(open.nc(ncfile, mpi_comm=1), silent=TRUE)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
cat("Testing that var.par.nc fails ... ")
ncid <- create.nc(ncfile, format="netcdf4")
x <- try(var.par.nc(ncid, "dummy", "NC_COLLECTIVE"), silent=TRUE)
close.nc(ncid)
unlink(ncfile)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
}
#-------------------------------------------------------------------------------#
# Check that package can be unloaded:
#-------------------------------------------------------------------------------#
cat("Unload RNetCDF ...\n")
detach("package:RNetCDF",unload=TRUE)
#-------------------------------------------------------------------------------#
# Overall summary
#-------------------------------------------------------------------------------#
cat("Summary:", tally["pass"], "pass /", tally["fail"], "fail.\n")
if (tally["fail"]==0) {
cat("Package seems to work properly.\n")
} else {
stop(tally["fail"]," of ",sum(tally)," test cases failed.")
}
#===============================================================================#
#===============================================================================#
# SCRATCH
#===============================================================================#
Try the RNetCDF package in your browser
Any scripts or data that you put into this service are public.
RNetCDF documentation built on Oct. 23, 2023, 9:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#===============================================================================#
#
# Name: RNetCDF-test.R
#
# Version: 2.8-1
#
# Purpose: Test functions to the NetCDF interface for R.
#
# Author: Pavel Michna (rnetcdf-devel@bluewin.ch)
# Milton Woods (miltonjwoods@gmail.com)
#
# Copyright (C) 2004-2023 Pavel Michna and Milton Woods.
#
#===============================================================================#
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with this program; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
#===============================================================================#
# Fail on warnings:
options(warn=2)
# tools::assertWarning is not defined in old R versions,
# so define a local function with similar behaviour:
assertWarning <- function(expr) {
warn <- FALSE
withCallingHandlers(expr,
warning=function(w) {
warn <<- TRUE
invokeRestart("muffleWarning")
}
)
if (!warn) {
stop("Expected warning from expression, but none occurred")
}
}
#===============================================================================#
# Load library
#===============================================================================#
library(RNetCDF)
has_bit64 <- require(bit64)
loadNamespace("tools")
#===============================================================================#
# Optional NetCDF features detected during package installation.
# Note that config.nc is not intended for user code.
# If necessary, users can handle missing features using 'try'.
#===============================================================================#
cfg <- config.nc()
#===============================================================================#
# Run tests
#===============================================================================#
#-------------------------------------------------------------------------------#
# NetCDF library functions
#-------------------------------------------------------------------------------#
#--Initialize ------------------------------------------------------------------#
cat("Starting NetCDF tests...\n")
testfun <- function(x,y,tally=NULL) {
if (is.null(tally)) {
tally <- c(pass=0,fail=0)
}
# Compare numeric values with single precision tolerance:
if (isTRUE(all.equal(x,y,tolerance=2^(-23)))) {
cat("OK\n")
return(tally+c(1,0))
} else {
cat("Failed\n")
cat("x:\n")
str(x)
print(attributes(x))
cat("y:\n")
str(y)
print(attributes(y))
return(tally+c(0,1))
}
}
tally <- NULL
## Create a new NetCDF dataset and define dimensions
for (format in c("classic","offset64","data64","classic4","netcdf4")) {
ncfile <- tempfile(paste("RNetCDF-test", format, "", sep="_"),
fileext=".nc")
cat("Test", format, "file format in", ncfile, "...\n")
if (format == "data64" && !cfg$data64) {
message("NetCDF library does not support file format data64")
nc <- try(create.nc(ncfile, format=format), silent=TRUE)
tally <- testfun(inherits(nc, "try-error"), TRUE, tally)
unlink(ncfile)
next
}
nc <- create.nc(ncfile, format=format)
tally <- testfun(TRUE, TRUE, tally)
# Show library version:
libvers <- file.inq.nc(nc)$libvers
cat("Version of netcdf library ... ", libvers, "\n")
verstr <- sub(' .*', '', file.inq.nc(nc)$libvers)
nstation <- 5
ntime <- 2
nstring <- 7
nempty <- 0
cat("Defining dimensions ...\n")
dim.def.nc(nc, "station", nstation)
dim.def.nc(nc, "time", ntime)
dim.def.nc(nc, "max_string_length", nstring)
dim.def.nc(nc, "empty", unlim=TRUE)
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
## Define a group
cat("Defining a group ...\n")
ncroot <- nc
nc <- grp.def.nc(nc, "testgrp")
tally <- testfun(TRUE, TRUE, tally)
## Define a type of each class:
cat("Defining user-defined types ...\n")
id_blob <- type.def.nc(nc, "blob", "opaque", size=128)
inq_blob <- list(id=id_blob, name="blob", class="opaque", size=128)
id_vector <- type.def.nc(nc, "vector", "vlen", basetype="NC_INT")
inq_vector <- list(id=id_vector, name="vector", class="vlen",
size=NA, basetype="NC_INT")
id_vector_char <- type.def.nc(nc, "vector_char", "vlen", basetype="NC_CHAR")
inq_vector_char <- list(id=id_vector_char, name="vector_char", class="vlen",
size=NA, basetype="NC_CHAR")
id_vector_string <- type.def.nc(nc, "vector_string", "vlen", basetype="NC_STRING")
inq_vector_string <- list(id=id_vector_string, name="vector_string", class="vlen",
size=NA, basetype="NC_STRING")
id_vector_blob <- type.def.nc(nc, "vector_blob", "vlen", basetype=id_blob)
inq_vector_blob <- list(id=id_vector_blob, name="vector_blob", class="vlen",
size=NA, basetype="blob")
id_factor <- type.def.nc(nc, "factor", "enum", basetype="NC_USHORT",
names=c("NA", "peanut butter", "jelly"),
values=c(100, 101, 102))
inq_factor <- list(id=id_factor, name="factor", class="enum",
size=2, basetype="NC_USHORT",
value=c("NA"=100,"peanut butter"=101,"jelly"=102))
id_struct <- type.def.nc(nc, "struct", "compound",
names=c("siteid", "height", "colour"),
subtypes=c("NC_INT", "NC_DOUBLE", "NC_SHORT"),
dimsizes=list(NULL, NULL, c(3)))
inq_struct <- list(id=id_struct, name="struct", class="compound", size=18,
offset=c(siteid=0,height=4,colour=12),
subtype=c(siteid="NC_INT",height="NC_DOUBLE",colour="NC_SHORT"),
dimsizes=list("siteid"=NULL,"height"=NULL,"colour"=c(3)))
typeids <- c(id_blob, id_vector, id_vector_char, id_vector_string,
id_vector_blob, id_factor, id_struct)
if (package_version(verstr) >= package_version("4.9.0")) {
id_vector_vector <- type.def.nc(nc, "vector_vector", "vlen", basetype=id_vector)
inq_vector_vector <- list(id=id_vector_vector, name="vector_vector", class="vlen",
size=NA, basetype="vector")
typeids <- c(typeids, id_vector_vector)
}
tally <- testfun(TRUE, TRUE, tally)
}
## Define variables
cat("Defining variables for netcdf3 ...\n")
var.def.nc(nc, "time", "NC_INT", "time")
inq_temperature <- list()
inq_temperature$id <- var.def.nc(nc, "temperature", "NC_DOUBLE", c(0,1),
chunking=TRUE, chunksizes=c(5,1),
deflate=5, shuffle=TRUE, big_endian=TRUE,
fletcher32=TRUE)
inq_temperature$name <- "temperature"
inq_temperature$type <- "NC_DOUBLE"
inq_temperature$ndims <- as.integer(2)
inq_temperature$dimids <- as.integer(c(0,1))
inq_temperature$natts <- as.integer(0)
inq_temperature$chunksizes <- as.numeric(c(5,1))
inq_temperature$deflate <- as.integer(5)
inq_temperature$shuffle <- TRUE
inq_temperature$big_endian <- TRUE
inq_temperature$fletcher32 <- TRUE
var.def.nc(nc, "packvar", "NC_BYTE", c("station"))
var.def.nc(nc, "name", "NC_CHAR", c("max_string_length", "station"))
var.def.nc(nc, "name_fill", "NC_CHAR", c("max_string_length", "station"))
var.def.nc(nc, "qcflag", "NC_CHAR", c("station"))
var.def.nc(nc, "int0", "NC_INT", NA)
var.def.nc(nc, "char0", "NC_CHAR", NA)
var.def.nc(nc, "numempty", "NC_FLOAT", c("station","empty"))
varcnt <- 9
numtypes <- c("NC_BYTE", "NC_SHORT", "NC_INT", "NC_FLOAT", "NC_DOUBLE")
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Defining variables for netcdf4 ...\n")
var.def.nc(nc, "namestr", "NC_STRING", c("station"))
var.def.nc(nc, "namestr_fill", "NC_STRING", c("station"))
var.def.nc(nc, "profile", id_vector, c("station","time"))
var.def.nc(nc, "profile_fill", id_vector, c("station","time"))
var.def.nc(nc, "profile_pack", id_vector, c("station","time"))
att.put.nc(nc, "profile_pack", "scale_factor", "NC_FLOAT", 10)
var.def.nc(nc, "profile_char", id_vector_char, c("station","time"))
var.def.nc(nc, "profile_string", id_vector_string, c("station","time"))
var.def.nc(nc, "profile_blob", id_vector_blob, c("time"))
var.def.nc(nc, "profile_scalar", id_vector, NA)
var.def.nc(nc, "rawdata", id_blob, c("station","time"))
var.def.nc(nc, "rawdata_scalar", id_blob, NA)
var.def.nc(nc, "rawdata_vector", id_blob, c("station"))
var.def.nc(nc, "snacks", "factor", c("station", "time"))
var.def.nc(nc, "snacks_empty", "factor", c("station", "time"))
var.def.nc(nc, "person", "struct", c("station", "time"))
var.def.nc(nc, "person_fill", "struct", c("station", "time"))
varcnt <- varcnt+16
if (package_version(verstr) >= package_version("4.9.0")) {
var.def.nc(nc, "profile_vector", id_vector_vector, c("station","time"))
var.def.nc(nc, "profile_vector_fill", id_vector_vector, c("station","time"))
varcnt <- varcnt+2
}
tally <- testfun(TRUE, TRUE, tally)
numtypes <- c(numtypes, "NC_UBYTE", "NC_USHORT", "NC_UINT")
if (has_bit64) {
var.def.nc(nc, "stationid", "NC_UINT64", c("station"))
varcnt <- varcnt+1
numtypes <- c(numtypes, "NC_INT64", "NC_UINT64")
tally <- testfun(TRUE, TRUE, tally)
}
inq_filter <- list()
inq_filter$filter_id <- c(2,1) # Shuffle, deflate
inq_filter$filter_params <- list(numeric(0),c(9))
var.def.nc(nc, "temp_filter", "NC_FLOAT", c("station", "time"),
chunking=TRUE, filter_id=inq_filter$filter_id,
filter_params=inq_filter$filter_params)
varcnt <- varcnt+1
}
for (numtype in numtypes) {
for (namode in seq(0,5)) {
cat("Defining variables of type", numtype, "for na.mode", namode, "...\n")
varname <- paste(numtype,namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"int",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"fill",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"intfill",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"pack",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"intpack",namode,sep="_")
var.def.nc(nc, varname, numtype, "station")
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"inf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"packinf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varname <- paste(numtype,"intpackinf",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varcnt <- varcnt+9
if (numtype == "NC_DOUBLE") {
varname <- paste(numtype,"fillna",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, as.double(NA))
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(as.double(-Inf),as.double(Inf)))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, as.double(NA))
}
tally <- testfun(TRUE, TRUE, tally)
varcnt <- varcnt+1
}
if (numtype == "NC_INT") {
varname <- paste(numtype,"intfillna",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, as.integer(NA))
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, as.integer(NA))
}
tally <- testfun(TRUE, TRUE, tally)
varcnt <- varcnt+1
}
if (has_bit64) {
varname <- paste(numtype,"bit64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_range", numtype, c(1,5))
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"fill64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"pack64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 10)
att.put.nc(nc, varname, "add_offset", numtype, 5)
if (namode == 2) {
att.put.nc(nc, varname, "missing_value", numtype, 99)
} else if (namode == 4) {
att.put.nc(nc, varname, "valid_min", numtype, 1)
att.put.nc(nc, varname, "valid_max", numtype, 5)
} else {
att.put.nc(nc, varname, "_FillValue", numtype, 99)
}
tally <- testfun(TRUE, TRUE, tally)
varname <- paste(numtype,"packinf64",namode,sep="_")
var.def.nc(nc, varname, numtype, c("station"))
att.put.nc(nc, varname, "scale_factor", numtype, 0)
varcnt <- varcnt+4
}
}
}
cat("Defining additional attributes ...")
## Set a _FillValue attribute for temperature
att.put.nc(nc, "temperature", "_FillValue", "NC_DOUBLE", -99999.9)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
## Set a _FillValue attribute for name_fill:
att.put.nc(nc, "name_fill", "_FillValue", "NC_CHAR", "X")
## Define the packing used by packvar
id_double <- type.inq.nc(nc, "NC_DOUBLE")$id
att.put.nc(nc, "packvar", "scale_factor", id_double, 10)
att.put.nc(nc, "packvar", "add_offset", "NC_DOUBLE", -5)
## Define some additional test attributes:
att_text <- "This is some text"
att_text2 <- c("This is string 1", "This is string 2")
att.put.nc(nc, "NC_GLOBAL", "char_att", "NC_CHAR", att_text)
att.put.nc(nc, "name", "char_att", "NC_CHAR", att_text)
att.put.nc(nc, "name", "raw_att", "NC_CHAR", charToRaw(att_text))
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Defining additional attributes for netcdf4 ...")
att.put.nc(nc, "temperature", "string_att", "NC_STRING", att_text2)
tally <- testfun(TRUE, TRUE, tally)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
if (has_bit64) {
hugeint <- as.integer64("-1234567890123456789")
att.put.nc(nc, "temperature", "int64_att", "NC_INT64", hugeint)
inq_temperature$natts <- inq_temperature$natts + as.integer(1)
tally <- testfun(TRUE, TRUE, tally)
}
}
## Define variable values
mytime <- c(1:2)
mytemperature <- matrix(c(1.1, 2.2, 3.3, 4.4, 5.5, 6.6, 7.7, NA, NA, 9.9),ncol=ntime)
mypackvar <- seq_len(5)*10-5
myname <- c("alfa", "bravo", "charlie", "delta", "echo")
myqcflag <- "ABCDE"
myint0 <- 12345
mychar0 <- "?"
mynamefill <- myname
for (ii in seq_along(myname)) {
mynamefill[ii] <- paste(rep("X", nstring), collapse="")
substr(mynamefill[ii], 1, nstring) <- myname[ii]
}
mynamestr <- myname
mynamestr[5] <- "NA"
mynamestr_fill <- myname
mynamestr_fill[5] <- NA
mysmall <- as.double(c(1,2,3,4,5))
mybig <- mysmall*1e100
myminus <- -mysmall
mysmallfill <- as.double(c(1,2,NA,4,5))
mybigfill <- mysmallfill*1e100
mypack <- mysmallfill*10+5
myinffill <- c(-Inf,.Machine$double.xmin,NA,NaN,Inf)
myinf <- c(1,2,-Inf,4,5)
if (has_bit64) {
mysmall64 <- as.integer64(mysmall)
mysmallfill64 <- as.integer64(mysmallfill)
myminus64 <- -mysmall64
mybig64 <- as.integer64("1234567890123456789")+mysmall
mybigfill64 <- as.integer64("1234567890123456789")+mysmallfill
mypack64 <- as.integer64(mypack)
}
if (format == "netcdf4") {
profiles <- vector("list", nstation*ntime)
dim(profiles) <- c(nstation, ntime)
for (ii in seq_len(nstation)) {
for (jj in seq_len(ntime)) {
# Profiles have increasing length, starting from 0:
profiles[[ii,jj]] <- 10*seq_len(ii+jj-2)*(ii+jj)
}
}
profiles_char <- lapply(profiles,function(x) {paste(as.character(x),collapse=",")})
dim(profiles_char) <- dim(profiles)
profiles_string <- lapply(profiles, as.character)
dim(profiles_string) <- dim(profiles)
if (package_version(verstr) >= package_version("4.9.0")) {
profiles_vector <- lapply(profiles, function(x) {lapply(x, seq_len)})
dim(profiles_vector) <- dim(profiles)
profiles_vector_fill <- profiles_vector
profiles_vector_fillval <- list(list(-999999999))
profiles_vector[[3]][[2]][5] <- -999999999
profiles_vector_fill[[3]][[2]][5] <- NA
}
profiles_fill <- profiles
profiles_fillval <- list(-999999999)
profiles[[3]][2] <- -999999999
profiles_fill[[3]][2] <- NA
rawdata <- as.raw(seq_len(nstation*ntime*128) %% 256)
dim(rawdata) <- c(128,nstation,ntime)
profiles_blob <- list(rawdata[,3:5,1], rawdata[,0,1])
dim(profiles_blob) <- ntime
snack_foods <- names(inq_factor$value)
snacks <- factor(rep(snack_foods, length.out=nstation*ntime),
levels=snack_foods)
dim(snacks) <- c(nstation, ntime)
snacks_fill <- snacks
snacks_fill[snacks_fill == "NA"] <- NA
snacks_empty <- snacks
snacks_empty[] <- NA
person <- list(siteid=array(rep(seq(1,nstation),ntime), c(nstation,ntime)),
height=array(1+0.1*seq(1,nstation*ntime), c(nstation,ntime)),
colour=array(rep(c(0,0,0,64,128,192),nstation), c(3,nstation,ntime)))
person_fillval <- list(siteid=person$siteid[1,1],
height=person$height[1,1],
colour=person$colour[,1,1])
person_fill <- person
person_fill$siteid[person_fill$siteid == person_fillval$siteid] <- NA
person_fill$height[person_fill$height == person_fillval$height] <- NA
# Note that array in compound uses same fill value for all elements:
person_fill$colour[person_fill$colour == person_fillval$colour[1]] <- NA
}
## Define some user-defined test attributes:
if (format == "netcdf4") {
cat("Defining user-defined attributes ...")
person1 <- list(siteid=array(person$siteid[1,1], 1),
height=array(person$height[1,1], 1),
colour=array(person$colour[,1,1], c(3,1)))
person3 <- list(siteid=array(person$siteid[1:3,1], 3),
height=array(person$height[1:3,1], 3),
colour=array(person$colour[,1:3,1], c(3,3)))
att.put.nc(nc, "NC_GLOBAL", "compound_scal_att", "struct", person1)
att.put.nc(nc, "NC_GLOBAL", "compound_vect_att", "struct", person3)
att.put.nc(nc, "NC_GLOBAL", "enum_scal_att", "factor", snacks[1])
att.put.nc(nc, "NC_GLOBAL", "enum_vect_att", "factor", snacks[1:3])
att.put.nc(nc, "NC_GLOBAL", "opaque_scal_att", "blob", rawdata[,1,1])
att.put.nc(nc, "NC_GLOBAL", "opaque_vect_att", "blob", rawdata[,1,])
att.put.nc(nc, "NC_GLOBAL", "vector_scal_att", "vector", profiles[1])
att.put.nc(nc, "NC_GLOBAL", "vector_vect_att", "vector", profiles[1:3])
tally <- testfun(TRUE, TRUE, tally)
# Fill values for strings and user-defined variables:
att.put.nc(nc, "namestr_fill", "_FillValue", "NC_STRING", "_MISSING")
att.put.nc(nc, "snacks", "_FillValue", "factor", factor("NA"))
att.put.nc(nc, "person_fill", "_FillValue", "struct", person_fillval)
att.put.nc(nc, "profile_fill", "_FillValue", id_vector,
profiles_fillval)
if (package_version(verstr) >= package_version("4.9.0")) {
att.put.nc(nc, "profile_vector_fill", "_FillValue", id_vector_vector,
profiles_vector_fillval)
}
}
## Put the data
cat("Writing netcdf3 variables ...")
var.put.nc(nc, "time", mytime, 1, length(mytime))
var.put.nc(nc, "temperature", mytemperature, c(1,1), c(nstation,ntime),
cache_preemption=0.5)
var.put.nc(nc, "packvar", mypackvar, pack=TRUE)
var.put.nc(nc, "name", myname, c(1,1), c(nstring,nstation))
var.put.nc(nc, "name_fill", myname, na.mode=5)
var.put.nc(nc, "qcflag", charToRaw(myqcflag))
var.put.nc(nc, "int0", myint0)
var.put.nc(nc, "char0", mychar0)
tally <- testfun(TRUE, TRUE, tally)
if (format == "netcdf4") {
cat("Writing extra netcdf4 variables ...")
var.put.nc(nc, "namestr", mynamestr_fill)
var.put.nc(nc, "namestr_fill", mynamestr_fill, na.mode=5)
var.put.nc(nc, "profile", profiles)
var.put.nc(nc, "profile_fill", profiles_fill, na.mode=5)
var.put.nc(nc, "profile_pack", profiles, pack=TRUE)
var.put.nc(nc, "profile_char", profiles_char)
var.put.nc(nc, "profile_string", profiles_string)
var.put.nc(nc, "profile_blob", profiles_blob)
var.put.nc(nc, "profile_scalar", profiles[1])
var.put.nc(nc, "rawdata", rawdata)
var.put.nc(nc, "rawdata_scalar", rawdata[,1,1])
var.put.nc(nc, "rawdata_vector", rawdata[,,1])
if (package_version(verstr) >= package_version("4.9.0")) {
var.put.nc(nc, "profile_vector", profiles_vector)
var.put.nc(nc, "profile_vector_fill", profiles_vector_fill, na.mode=5)
}
y <- try(var.put.nc(nc, "snacks", snacks_fill, na.mode=3), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
var.put.nc(nc, "snacks", snacks_fill, na.mode=5)
tally <- testfun(TRUE, TRUE, tally)
var.put.nc(nc, "person", person, na.mode=3)
tally <- testfun(TRUE, TRUE, tally)
var.put.nc(nc, "person_fill", person_fill, na.mode=5)
tally <- testfun(TRUE, TRUE, tally)
if (has_bit64) {
var.put.nc(nc, "stationid", mybig64)
tally <- testfun(TRUE, TRUE, tally)
}
var.put.nc(nc, "temp_filter", mytemperature)
tally <- testfun(TRUE, TRUE, tally)
}
for (numtype in numtypes) {
for (namode in seq(0,5)) {
cat("Writing to variable type", numtype, "with na.mode", namode, "...\n")
# Should not succeed except for NC_DOUBLE:
cat("Writing huge values ...")
y <- try(var.put.nc(nc, paste(numtype,namode,sep="_"), mybig, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype!="NC_DOUBLE", tally)
y <- try(var.put.nc(nc, paste(numtype,"fill",namode,sep="_"), mybigfill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype!="NC_DOUBLE", tally)
# Should not succeed except for NC_FLOAT and 64-bit types:
if (has_bit64) {
cat("Writing huge bit64 values ...")
y <- try(var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), mybig64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), !(numtype %in% c("NC_FLOAT","NC_INT64","NC_UINT64","NC_DOUBLE")), tally)
}
# Should not succeed for unsigned types:
cat("Writing negative values ...")
y <- try(var.put.nc(nc, paste(numtype,namode,sep="_"), myminus, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"),
any(numtype==c("NC_UBYTE", "NC_USHORT", "NC_UINT", "NC_UINT64")),
tally)
# Allow wrapping of negative bit64 values when converting to NC_UINT64:
if (has_bit64) {
cat("Writing negative bit64 values ...")
y <- try(var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), myminus64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), numtype %in% c("NC_UBYTE","NC_USHORT","NC_UINT"), tally)
}
# Should succeed for all types:
cat("Writing data without missing values ...")
var.put.nc(nc, paste(numtype,namode,sep="_"), mysmall, na.mode=namode)
var.put.nc(nc, paste(numtype,"int",namode,sep="_"), as.integer(mysmall), na.mode=namode)
tally <- testfun(TRUE, TRUE, tally)
if (has_bit64) {
cat("Writing bit64 data without missing values ...")
var.put.nc(nc, paste(numtype,"bit64",namode,sep="_"), mysmall64, na.mode=namode)
tally <- testfun(TRUE, TRUE, tally)
}
# Should succeed except in the following cases:
inffail <- !(numtype %in% c("NC_FLOAT","NC_DOUBLE"))
nafail <- (namode==3 && !(numtype %in% c("NC_FLOAT","NC_DOUBLE")))
naintfail <- (namode==3 && !(numtype %in% c("NC_INT","NC_INT64","NC_FLOAT","NC_DOUBLE")))
nabit64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_UINT64","NC_FLOAT","NC_DOUBLE")))
napack64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_FLOAT","NC_DOUBLE")))
cat("Writing Inf values ...")
y <- try(var.put.nc(nc, paste(numtype,"inf",namode,sep="_"), myinf, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing doubles with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"packinf",namode,sep="_"), mypack, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing integers with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"intpackinf",namode,sep="_"), as.integer(mypack), pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
cat("Writing data with missing values ...")
y <- try(var.put.nc(nc, paste(numtype,"fill",namode,sep="_"), mysmallfill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
y <- try(var.put.nc(nc, paste(numtype,"intfill",namode,sep="_"), as.integer(mysmallfill), na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
if (numtype == "NC_INT") {
cat("Writing data with missing values and NA fill ...")
y <- try(var.put.nc(nc, paste(numtype,"intfillna",namode,sep="_"), as.integer(mysmallfill), na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
} else if (numtype == "NC_DOUBLE") {
cat("Writing data with non-finite values and NA fill ...")
y <- try(var.put.nc(nc, paste(numtype,"fillna",namode,sep="_"), myinffill, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
}
cat("Writing data with missing values and packing ...")
y <- try(var.put.nc(nc, paste(numtype,"pack",namode,sep="_"), mypack, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nafail, tally)
y <- try(var.put.nc(nc, paste(numtype,"intpack",namode,sep="_"), as.integer(mypack), pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), naintfail, tally)
if (has_bit64) {
cat("Writing bit64 data with missing values ...")
y <- try(var.put.nc(nc, paste(numtype,"fill64",namode,sep="_"), mysmallfill64, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), nabit64fail, tally)
cat("Writing bit64 data with missing values and packing ...")
y <- try(var.put.nc(nc, paste(numtype,"pack64",namode,sep="_"), mypack64, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), napack64fail, tally)
cat("Writing integer64 with non-finite packing ...")
y <- try(var.put.nc(nc, paste(numtype,"packinf64",namode,sep="_"), mypack64, pack=TRUE, na.mode=namode), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), inffail, tally)
}
}
}
if (format == "netcdf4") {
# Check chunk cache settings for temperature:
cat("Check chunk cache settings after writing temperature ...")
x <- var.inq.nc(nc, "temperature")$cache_preemption
if (is.na(x)) {
cat("Feature not available in this NetCDF library version.\n")
} else {
y <- 0.5
tally <- testfun(x,y,tally)
}
# Check multi-filter inquiry:
cat("Check filter settings after writing temp_filter ...")
x <- var.inq.nc(nc, "temp_filter")
if (is.null(x$filter_id) && is.null(x$filter_params)) {
cat("Multi-filters not available in this NetCDF library version.\n")
} else {
tally <- testfun(x[names(inq_filter)], inq_filter, tally)
}
}
# sync.nc(nc)
if (format == "netcdf4") {
close.nc(ncroot)
ncroot <- open.nc(ncfile)
nc <- grp.inq.nc(ncroot, "testgrp")$self
} else {
close.nc(nc)
nc <- open.nc(ncfile)
}
cat("Check file format ...")
x <- file.inq.nc(nc)$format
y <- format
tally <- testfun(x,y,tally)
## Display file structure
print.nc(nc)
## Read tests
cat("Read NC_CHAR global attribute ...")
x <- att_text
y <- att.get.nc(nc, "NC_GLOBAL", "char_att")
tally <- testfun(x,y,tally)
cat("Read NC_CHAR variable attribute ...")
x <- att_text
y <- att.get.nc(nc, "name", "char_att")
tally <- testfun(x,y,tally)
cat("Read NC_CHAR variable attribute as raw bytes ...")
x <- charToRaw(att_text)
y <- att.get.nc(nc, "name", "raw_att", rawchar=TRUE)
tally <- testfun(x,y,tally)
if (format == "netcdf4") {
cat("Read NC_STRING variable attribute ...")
x <- att_text2
y <- att.get.nc(nc, "temperature", "string_att")
tally <- testfun(x,y,tally)
if (has_bit64) {
cat("Read NC_INT64 variable attribute ...")
x <- hugeint
y <- att.get.nc(nc, "temperature", "int64_att", fitnum=TRUE)
tally <- testfun(x,y,tally)
cat("Read NC_INT64 variable attribute as numeric ...")
x <- suppressWarnings(as.numeric(hugeint))
y <- att.get.nc(nc, "temperature", "int64_att")
tally <- testfun(x,y,tally)
}
}
grpinfo <- grp.inq.nc(nc)
cat("Inquire about groups in file/group ...")
tally <- testfun(grpinfo$grps,list(),tally)
cat("Inquire about dimension ids in file/group ...")
tally <- testfun(grpinfo$dimids,c(0:3),tally)
cat("Inquire about variable ids in file/group ...")
tally <- testfun(grpinfo$varids,c(0:(varcnt-1)),tally)
cat("Inquire about fullname of file/group ...")
if (format == "netcdf4") {
tally <- testfun(grpinfo$fullname,"/testgrp",tally)
} else {
tally <- testfun(grpinfo$fullname,"/",tally)
}
cat("Inquire about unlimited dimension ids of file/group ...")
if (format == "netcdf4") {
# Some versions of netcdf4 do not list unlimited dimensions in ancestor groups:
if (length(grpinfo$unlimids)==0) {
tally <- testfun(grpinfo$unlimids,integer(0),tally)
} else {
tally <- testfun(grpinfo$unlimids,3,tally)
}
} else {
tally <- testfun(grpinfo$unlimids,3,tally)
}
if (format == "netcdf4") {
cat("Inquire about user-defined types in file/group ...")
tally <- testfun(grpinfo$typeids,typeids,tally)
}
cat("Read integer vector as double ... ")
x <- mytime
dim(x) <- length(x)
y <- var.get.nc(nc, 0)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
for (numtype in numtypes) {
for (namode in seq(0,5)) {
x <- mysmall
dim(x) <- length(x)
varname <- paste(numtype,namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
varname <- paste(numtype,"int",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
if (has_bit64) {
varname <- paste(numtype,"bit64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
# Some cases are expected to fail when writing the data,
# so there is nothing to read:
nafail <- (namode==3 && numtype != "NC_DOUBLE")
naintfail <- (namode==3 && !(numtype %in% c("NC_INT","NC_INT64","NC_FLOAT","NC_DOUBLE")))
nabit64fail <- (namode==3 && !(numtype %in% c("NC_INT64","NC_FLOAT","NC_DOUBLE")))
x <- mysmallfill
dim(x) <- length(x)
if (!nafail) {
varname <- paste(numtype,"fill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
if (!naintfail) {
varname <- paste(numtype,"intfill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (has_bit64 && !nabit64fail) {
varname <- paste(numtype,"fill64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (numtype == "NC_INT" && !naintfail) {
x <- mysmallfill
dim(x) <- length(x)
varname <- paste(numtype,"intfillna",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
} else if (numtype == "NC_DOUBLE" && !nafail) {
x <- myinffill
dim(x) <- length(x)
varname <- paste(numtype,"fillna",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
x <- mypack
dim(x) <- length(x)
if (!nafail) {
varname <- paste(numtype,"pack",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
tally <- testfun(x,y,tally)
tally <- testfun(is.double(y),TRUE,tally)
}
if (!naintfail) {
varname <- paste(numtype,"intpack",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
if (has_bit64 && !nabit64fail) {
varname <- paste(numtype,"pack64",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, unpack=TRUE, na.mode=namode)
if (namode==3) {
tally <- testfun(x[!is.na(x)],y[!is.na(x)],tally)
tally <- testfun(isTRUE(all.equal(x[is.na(x)],y[is.na(x)])),FALSE,tally)
} else {
tally <- testfun(x,y,tally)
}
tally <- testfun(is.double(y),TRUE,tally)
}
}
}
cat("Read integer vector as smallest R type ... ")
x <- mytime
dim(x) <- length(x)
y <- var.get.nc(nc, 0, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),TRUE,tally)
for (numtype in numtypes) {
x <- mysmall
if (has_bit64 && any(numtype==c("NC_INT64","NC_UINT64"))) {
x <- as.integer64(x)
}
dim(x) <- length(x)
varname <- paste(numtype,namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),
any(numtype==c("NC_BYTE","NC_UBYTE","NC_SHORT","NC_USHORT","NC_INT")),
tally)
x <- mysmallfill
if (has_bit64 && any(numtype==c("NC_INT64","NC_UINT64"))) {
x <- as.integer64(x)
}
dim(x) <- length(x)
varname <- paste(numtype,"fill",namode,sep="_")
cat("Read", varname, "...")
y <- var.get.nc(nc, varname, fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(is.integer(y),
any(numtype==c("NC_BYTE","NC_UBYTE","NC_SHORT","NC_USHORT","NC_INT")),
tally)
}
cat("Read numeric matrix ... ")
x <- mytemperature
y <- var.get.nc(nc, "temperature", cache_preemption=0.4)
tally <- testfun(x,y,tally)
cat("Inquire about numeric variable ...")
x <- inq_temperature
y <- var.inq.nc(nc, "temperature")
var_inq_names <- c("id", "name", "type", "ndims", "dimids", "natts")
if (format == "netcdf4") {
var_inq_names_nc4 <- c(var_inq_names, "chunksizes", "deflate", "shuffle",
"fletcher32")
tally <- testfun(x[var_inq_names_nc4], y[var_inq_names_nc4], tally)
big_endian <- y$big_endian
# May be NULL or NA for older netcdf libraries, TRUE otherwise.
if (!is.null(big_endian) && !isTRUE(is.na(big_endian))) {
tally <- testfun(TRUE, big_endian, tally)
}
preempt <- y$cache_preemption
# May be NULL for older netcdf libraries, numeric otherwise.
if (!is.null(preempt)) {
tally <- testfun(0.4, preempt, tally)
}
} else {
tally <- testfun(x[var_inq_names], y[var_inq_names], tally)
}
cat("Read numeric matrix slice ... ")
x <- mytemperature[,2,drop=FALSE]
y <- var.get.nc(nc, "temperature", c(NA,2), c(NA,1), collapse=FALSE)
tally <- testfun(x,y,tally)
x <- mytemperature[,2]
y <- var.get.nc(nc, "temperature", c(NA,2), c(NA,1), collapse=TRUE)
tally <- testfun(x,y,tally)
cat("Read numeric matrix empty slice ... ")
x <- numeric(0)
dim(x) <- c(0,1)
y <- var.get.nc(nc, "temperature", c(NA,2), c(0,1), collapse=FALSE)
tally <- testfun(x,y,tally)
y <- var.get.nc(nc, "temperature", c(NA,2), c(0,1), collapse=TRUE)
tally <- testfun(drop(x),y,tally)
cat("Read numeric scalar ... ")
x <- myint0
y <- var.get.nc(nc, "int0")
tally <- testfun(x,y,tally)
cat("Read numeric empty array ... ")
x <- numeric(0)
dim(x) <- c(nstation,nempty)
y <- var.get.nc(nc, "numempty")
tally <- testfun(x,y,tally)
cat("Read 2D char array ... ")
x <- myname
dim(x) <- length(x)
y <- var.get.nc(nc, "name")
tally <- testfun(x,y,tally)
cat("Read 2D char array with fill value ... ")
x <- mynamefill
dim(x) <- length(x)
y <- var.get.nc(nc, "name_fill", na.mode=3)
tally <- testfun(x,y,tally)
x <- myname
dim(x) <- length(x)
y <- var.get.nc(nc, "name_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read 2D char slice ... ")
x <- substring(myname[2:3],1,4)
dim(x) <- length(x)
y <- var.get.nc(nc, "name", c(1,2), c(4,2))
tally <- testfun(x,y,tally)
cat("Read 2D char slice as raw bytes ... ")
x <- substring(myname[2:3],1,4)
dim(x) <- length(x)
x <- apply(x,MARGIN=1,FUN=charToRaw)
y <- var.get.nc(nc, "name", c(1,2), c(4,2), rawchar=TRUE)
tally <- testfun(x,y,tally)
cat("Read 2D char slice as characters ... ")
x <- myname[2:3]
dim(x) <- length(x)
y <- var.get.nc(nc, "name", c(1,2), c(NA,2))
tally <- testfun(x,y,tally)
cat("Read empty 2D char array ... ")
x <- character(0)
dim(x) <- 0
y <- var.get.nc(nc, "name", NA, c(0,0), collapse=FALSE)
tally <- testfun(x,y,tally)
y <- var.get.nc(nc, "name", NA, c(0,0), collapse=TRUE)
tally <- testfun(drop(x),y,tally)
cat("Read 1D char slice ... ")
x <- substring(myqcflag,2,3)
y <- var.get.nc(nc, "qcflag", c(2), c(2))
tally <- testfun(x,y,tally)
cat("Read scalar char ... ")
x <- mychar0
y <- var.get.nc(nc, "char0")
tally <- testfun(x,y,tally)
if (format == "netcdf4") {
cat("Read 1D string array ...")
x <- mynamestr
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr")
tally <- testfun(x,y,tally)
cat("Read 1D string array with fill values ...")
x <- mynamestr_fill
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read 1D string slice ...")
x <- mynamestr[2:3]
dim(x) <- length(x)
y <- var.get.nc(nc, "namestr", c(2), c(2))
tally <- testfun(x,y,tally)
if (has_bit64) {
cat("Read 1D int64 array as integer64 ...")
x <- mybig64
dim(x) <- length(x)
y <- var.get.nc(nc, "stationid", fitnum=TRUE)
tally <- testfun(x,y,tally)
}
cat("Read details of user-defined types ...")
x <- inq_blob
y <- type.inq.nc(nc, id_blob)
tally <- testfun(x,y,tally)
# Reported size may depend on netcdf version and pointer size:
x <- inq_vector[-4]
y <- type.inq.nc(nc, id_vector)[-4]
tally <- testfun(x,y,tally)
x <- inq_vector_char[-4]
y <- type.inq.nc(nc, id_vector_char)[-4]
tally <- testfun(x,y,tally)
x <- inq_vector_blob[-4]
y <- type.inq.nc(nc, id_vector_blob)[-4]
tally <- testfun(x,y,tally)
x <- inq_factor
y <- type.inq.nc(nc, id_factor)
tally <- testfun(x,y,tally)
x <- inq_factor[1:5]
y <- type.inq.nc(nc, id_factor, fields=FALSE)
tally <- testfun(x,y,tally)
# Size and offset of compound types may differ between writing and reading.
# The layout for writing (reading) is defined by the user (compiler).
x <- inq_struct[c(-4,-5)]
y <- type.inq.nc(nc, id_struct)[c(-4,-5)]
tally <- testfun(x,y,tally)
x <- inq_struct[1:3]
y <- type.inq.nc(nc, id_struct, fields=FALSE)[-4]
tally <- testfun(x,y,tally)
cat("Read vlen as double ...")
x <- profiles
y <- var.get.nc(nc, "profile")
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.double))), TRUE, tally)
cat("Read vlen as integer ...")
x <- profiles
y <- var.get.nc(nc, "profile", fitnum=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.integer))), TRUE, tally)
cat("Read vlen with fill ...")
x <- profiles_fill
y <- var.get.nc(nc, "profile_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read vlen scalar ...")
x <- profiles[1]
y <- var.get.nc(nc, "profile_scalar")
tally <- testfun(x,y,tally)
cat("Reading packed vlen ...")
x <- profiles
y <- var.get.nc(nc, "profile_pack", unpack=TRUE)
tally <- testfun(x,y,tally)
tally <- testfun(isTRUE(all(sapply(y,is.double))), TRUE, tally)
cat("Read character vlen ...")
x <- profiles_char
y <- var.get.nc(nc, "profile_char")
tally <- testfun(x,y,tally)
cat("Read character vlen as raw ...")
x <- lapply(profiles_char,charToRaw)
dim(x) <- dim(profiles_char)
y <- var.get.nc(nc, "profile_char", rawchar=TRUE)
tally <- testfun(x,y,tally)
cat("Read string vlen ...")
x <- profiles_string
y <- var.get.nc(nc, "profile_string")
tally <- testfun(x,y,tally)
if (package_version(verstr) >= package_version("4.9.0")) {
cat("Read nested vlen ...")
x <- profiles_vector
y <- var.get.nc(nc, "profile_vector", na.mode=3)
tally <- testfun(x,y,tally)
cat("Read nested vlen with fill ...")
x <- profiles_vector_fill
y <- var.get.nc(nc, "profile_vector_fill", na.mode=5)
tally <- testfun(x,y,tally)
}
cat("Read opaque ...")
x <- rawdata
y <- var.get.nc(nc, "rawdata")
tally <- testfun(x,y,tally)
cat("Read opaque scalar ...")
x <- rawdata[,1,1]
dim(x) <- length(x)
y <- var.get.nc(nc, "rawdata_scalar")
tally <- testfun(x,y,tally)
cat("Read opaque vector ...")
x <- rawdata[,,1]
y <- var.get.nc(nc, "rawdata_vector")
tally <- testfun(x,y,tally)
cat("Read opaque vlen ...")
x <- profiles_blob
y <- var.get.nc(nc, "profile_blob")
tally <- testfun(x,y,tally)
cat("Read enum ...")
x <- snacks
y <- var.get.nc(nc, "snacks", na.mode=3)
tally <- testfun(x,y,tally)
x <- snacks_fill
y <- var.get.nc(nc, "snacks", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read empty enum ...")
x <- snacks_empty
y <- NULL
assertWarning(y <- var.get.nc(nc, "snacks_empty"))
tally <- testfun(x,y,tally)
cat("Read compound ...")
x <- person
y <- var.get.nc(nc, "person", na.mode=3)
tally <- testfun(x,y,tally)
cat("Read compound with fill ...")
x <- person_fill
y <- var.get.nc(nc, "person_fill", na.mode=5)
tally <- testfun(x,y,tally)
cat("Read compound scalar attribute ...")
x <- person1
y <- att.get.nc(nc, "NC_GLOBAL", "compound_scal_att")
tally <- testfun(x,y,tally)
cat("Read compound vector attribute ...")
x <- person3
y <- att.get.nc(nc, "NC_GLOBAL", "compound_vect_att")
tally <- testfun(x,y,tally)
cat("Read enum scalar attribute ...")
x <- snacks[1]
y <- att.get.nc(nc, "NC_GLOBAL", "enum_scal_att")
tally <- testfun(x,y,tally)
cat("Read enum vector attribute ...")
x <- snacks[1:3]
y <- att.get.nc(nc, "NC_GLOBAL", "enum_vect_att")
tally <- testfun(x,y,tally)
cat("Read opaque scalar attribute ...")
x <- rawdata[,1,1]
dim(x) <- c(length(x),1)
y <- att.get.nc(nc, "NC_GLOBAL", "opaque_scal_att")
tally <- testfun(x,y,tally)
cat("Read opaque vector attribute ...")
x <- rawdata[,1,]
y <- att.get.nc(nc, "NC_GLOBAL", "opaque_vect_att")
tally <- testfun(x,y,tally)
cat("Read vlen scalar attribute ...")
x <- profiles[1]
y <- att.get.nc(nc, "NC_GLOBAL", "vector_scal_att")
tally <- testfun(x,y,tally)
cat("Read vlen vector attribute ...")
x <- profiles[1:3]
y <- att.get.nc(nc, "NC_GLOBAL", "vector_vect_att")
tally <- testfun(x,y,tally)
}
cat("Read and unpack numeric array ... ")
x <- mypackvar
dim(x) <- length(x)
y <- var.get.nc(nc, "packvar", unpack=TRUE)
tally <- testfun(x,y,tally)
cat("Check that closing any NetCDF handle closes the file for all handles ... ")
close.nc(nc)
y <- try(file.inq.nc(grpinfo$self), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
cat("Check that garbage collector closes file that is not referenced ... ")
attr(nc,"handle_ptr") <- NULL # NetCDF objects should not normally be modified
rm(grpinfo)
gc()
y <- try(file.inq.nc(nc), silent=TRUE)
tally <- testfun(inherits(y, "try-error"), TRUE, tally)
unlink(ncfile)
cat("Removed test file", ncfile, "\n")
}
# Try diskless files:
ncfile <- tempfile("RNetCDF-test-diskless", fileext=".nc")
cat("Test diskless creation of ", ncfile, "...\n")
if (cfg$diskless) {
nc <- create.nc(ncfile, diskless=TRUE)
tally <- testfun(file.exists(ncfile), FALSE, tally)
close.nc(nc)
} else {
message("NetCDF library does not support diskless datasets")
nc <- try(create.nc(ncfile, diskless=TRUE), silent=TRUE)
tally <- testfun(inherits(nc, "try-error"), TRUE, tally)
}
unlink(ncfile)
#-------------------------------------------------------------------------------#
# UDUNITS calendar functions
#-------------------------------------------------------------------------------#
# Test if udunits support is available:
if (!cfg$udunits) {
message("UDUNITS calendar conversions not supported by this build of RNetCDF")
x <- try(utcal.nc("seconds since 1970-01-01", 0), silent=TRUE)
tally <- testfun(inherits(x, "try-error"), TRUE, tally)
} else {
cat("utcal.nc - numeric values ...")
x <- matrix(data=c(1899, 1900, 1900, 1900, 1900, 1900,
12, 1, 1, 1, 1, 1,
31, 1, 1, 1, 1, 1,
23, 0, 1, 2, 3, 4,
0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0),
ncol=6)
colnames(x) <- c("year","month","day","hour","minute","second")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5))
tally <- testfun(x,y,tally)
cat("utcal.nc - string values ...")
x <- c("1899-12-31 23:00:00", "1900-01-01 00:00:00", "1900-01-01 01:00:00",
"1900-01-01 02:00:00", "1900-01-01 03:00:00", "1900-01-01 04:00:00")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5), type="s")
tally <- testfun(x,y,tally)
cat("utcal.nc - POSIXct values ...")
x <- ISOdatetime(c(1899,1900,1900,1900,1900,1900),
c( 12, 1, 1, 1, 1, 1),
c( 31, 1, 1, 1, 1, 1),
c( 23, 0, 1, 2, 3, 4),
c( 0, 0, 0, 0, 0, 0),
c( 0, 0, 0, 0, 0, 0), tz="UTC")
y <- utcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(0:5), type="c")
tally <- testfun(x,y,tally)
cat("utinvcal.nc - numeric values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00", c(1900,1,1,5,25,0))
tally <- testfun(x,y,tally)
cat("utinvcal.nc - string values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00", "1900-01-01 05:25:00")
tally <- testfun(x,y,tally)
cat("utinvcal.nc - POSIXct values ...")
x <- 6.416667
y <- utinvcal.nc("hours since 1900-01-01 00:00:00 +01:00",
ISOdatetime(1900,1,1,5,25,0,tz="UTC"))
tally <- testfun(x,y,tally)
}
#-------------------------------------------------------------------------------#
# Parallel I/O demos
#-------------------------------------------------------------------------------#
mpiexec <- cfg$mpiexec
parallel <- cfg$parallel
if (mpiexec != "") {
# mpiexec is specified, so assume that parallel I/O is meant to be enabled.
# List of MPI packages to test:
mpipkgs <- c("Rmpi", "pbdMPI")
# Try to find demo script directory:
demodirs <- c("demo",
file.path("..", "demo"),
file.path("..", "RNetCDF", "demo"))
demodir <- demodirs[dir.exists(demodirs)]
stopifnot(length(demodir) > 0)
# Check if any of the packages are loaded:
for (mpipkg in mpipkgs) {
if (isNamespaceLoaded(mpipkg)) {
warning("Package ", mpipkg, " is loaded, so mpiexec may fail")
}
}
for (mpipkg in c("Rmpi", "pbdMPI")) {
# We cannot use requireNamespace to check for installed MPI packages,
# because they may initialise the MPI library via .onLoad,
# which causes failure when we try to mpiexec another R script.
if (length(find.package(mpipkg, quiet=TRUE) > 0)) {
cat("Testing parallel I/O with package", mpipkg, "...\n")
demoscripts <- list.files(
demodir,
pattern=paste0(mpipkg, ".*\\.R"),
full.names=TRUE)
stopifnot(length(demoscripts) >= 1)
for (demoscript in demoscripts) {
ncfile <- tempfile("RNetCDF-MPI-test", fileext=".nc")
cat("Running script", demoscript, "with MPI ...\n")
x <- system2(mpiexec,
args=c('-n', '2', 'Rscript', '--vanilla', demoscript, ncfile))
unlink(ncfile)
tally <- testfun(x, 0, tally)
}
} else {
message("Package ", mpipkg, " not available for parallel I/O tests\n")
}
}
} else if (parallel) {
# Parallel I/O may be enabled, but we cannot test without mpiexec being specified.
cat("Skipping parallel I/O tests as mpiexec is not defined\n")
} else {
# Assume that parallel I/O is meant to be disabled,
# because parallel is FALSE and mpiexec is not specified.
ncfile <- tempfile("RNetCDF-MPI-test", fileext=".nc")
cat("Testing that create.nc fails with mpi_comm ... ")
x <- try(create.nc(ncfile, format="netcdf4", mpi_comm=1), silent=TRUE)
unlink(ncfile)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
cat("Testing that open.nc fails with mpi_comm ... ")
x <- try(open.nc(ncfile, mpi_comm=1), silent=TRUE)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
cat("Testing that var.par.nc fails ... ")
ncid <- create.nc(ncfile, format="netcdf4")
x <- try(var.par.nc(ncid, "dummy", "NC_COLLECTIVE"), silent=TRUE)
close.nc(ncid)
unlink(ncfile)
if (inherits(x, "try-error") &&
conditionMessage(attr(x, "condition")) == "MPI not supported") {
tally <- testfun(TRUE, TRUE, tally)
} else {
tally <- testfun(FALSE, TRUE, tally)
}
}
#-------------------------------------------------------------------------------#
# Check that package can be unloaded:
#-------------------------------------------------------------------------------#
cat("Unload RNetCDF ...\n")
detach("package:RNetCDF",unload=TRUE)
#-------------------------------------------------------------------------------#
# Overall summary
#-------------------------------------------------------------------------------#
cat("Summary:", tally["pass"], "pass /", tally["fail"], "fail.\n")
if (tally["fail"]==0) {
cat("Package seems to work properly.\n")
} else {
stop(tally["fail"]," of ",sum(tally)," test cases failed.")
}
#===============================================================================#
#===============================================================================#
# SCRATCH
#===============================================================================#
Try the RNetCDF package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.