Skip to content
GitLab
Commit 498f21fb authored by Nicolau Manubens Gil's avatar Nicolau Manubens Gil
Browse files

Merge branch 'develop-bugfixes-0.0.4' into 'master' 

Removed ncdf4 bugfix.



See merge request !8
parents 0324da13 a6bbe9c6
Hide whitespace changes
Inline Side-by-side
DESCRIPTION
View file @ 498f21fb
......@@ -3,8 +3,7 @@ Title: Tools to Easily Read/Write NetCDF Files into/from Multidimensional R Arra
Version: 0.0.3
Authors@R: c(
person("BSC-CNS", role = c("aut", "cph")),
person("Nicolau", "Manubens", , "nicolau.manubens@bsc.es", role = c("aut", "cre")),
person("David", "Pierce", , "david.pierce@ucsd.edu", role = c("ctb")))
person("Nicolau", "Manubens", , "nicolau.manubens@bsc.es", role = c("aut", "cre")))
Description: Set of wrappers for the 'ncdf4' package to simplify and extend its reading/writing capabilities into/from multidimensional R arrays.
Depends:
R (>= 2.14.1)
......@@ -16,4 +15,3 @@ URL: https://earth.bsc.es/gitlab/es/easyNCDF/wikis/home
BugReports: https://earth.bsc.es/gitlab/es/easyNCDF/issues
LazyData: true
SystemRequirements: netcdf development libraries
NeedsCompilation: yes
NAMESPACE
View file @ 498f21fb
useDynLib(easyNCDF)
exportPattern("^[^\\.]")
import(ncdf4, abind)
importFrom("stats", "setNames")
R/NcToArray.R
View file @ 498f21fb
......@@ -203,8 +203,8 @@ NcToArray <- function(file_to_read, dim_indices = NULL, vars_to_read = NULL,
(length(file_object[['var']][[var_name]][['dim']]) > 1)) {
start <- c(1, start)
count <- c(-1, count)
##original_ncvar_get_inner <- ncdf4:::ncvar_get_inner
##assignInNamespace('ncvar_get_inner', .ncvar_get_inner, 'ncdf4')
## original_ncvar_get_inner <- ncdf4:::ncvar_get_inner
## assignInNamespace('ncvar_get_inner', .ncvar_get_inner, 'ncdf4')
}
var_result <- do.call('[', c(list(.ncvar_get(file_object, var_name, start, count, collapse_degen = FALSE)),
lapply(indices_to_take, function(x) if (is_single_na(x)) TRUE else x - min(x) + 1), list(drop = FALSE)))
......
R/Utils.R
View file @ 498f21fb
......@@ -203,880 +203,3 @@
names(dim(array1)) <- names(dim(array2))
array1
}
# The functions from here on are copies of some functions in 'ncdf4' package
# with a small bugfix in ncvar_get_inner. When ncdf4 addresses this bug, these
# function will be removed from this package.
# This code belongs to David Pierce.
.ncvar_size <- function( ncid, varid ) {
if( mode(ncid) != 'numeric' )
stop(paste("error, must be passed a numeric first arg: ncid2use, not an arg of mode", mode(ncid)))
if( mode(varid) != 'numeric' )
stop("Error, must be passed a numeric second arg: varid2use" )
ndims <- .ncvar_ndims( ncid, varid )
if( ndims == 0 )
#return(vector()) changed DWP 2012-09-20
return(1) # indicates a scalar var
rv <- list()
rv$error <- -1
rv$varsize <- integer(ndims)
rv$ndims <- -1
rv <- .C("R_nc4_varsize",
as.integer(ncid),
as.integer(varid),
ndims=as.integer(rv$ndims),
varsize=as.integer(rv$varsize),
error=as.integer(rv$error),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("error returned from C routine R_nc4_varsize")
#-------------------------------------
# Switch order from C-style to R-style
#-------------------------------------
rv$varsize <- rv$varsize[ ndims:1 ]
return(rv$varsize)
}
.ncvar_type <- function( ncid, varid, output_string=FALSE ) {
if( mode(ncid) != 'numeric' )
stop("error, must be passed a numeric first arg: ncid2use")
if( mode(varid) != 'numeric' )
stop("Error, must be passed a numeric second arg: varid2use" )
rv <- list()
rv$error <- -1
rv$precint <- -1
rv <- .C("R_nc4_inq_vartype",
as.integer(ncid),
as.integer(varid),
precint=as.integer(rv$precint),
error=as.integer(rv$error),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("error returned from C call")
return( rv$precint )
}
.ncvar_ndims <- function( ncid, varid ) {
if( mode(ncid) != 'numeric' )
stop(paste("error, ncvar_ndims must be passed a numeric first arg; mode of val passed=", mode(ncid)))
if( mode(varid) != 'numeric' )
stop("Error, ncvar_ndims must be passed a numeric second arg: varid2use" )
rv <- list()
rv$error <- -1
rv$ndims <- -1
rv <- .C("R_nc4_inq_varndims",
as.integer(ncid),
as.integer(varid),
ndims=as.integer(rv$ndims),
error=as.integer(rv$error),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("error returned from C call")
return( rv$ndims )
}
.blankstring_ncdf4 <- function( n ) {
rv <- .Call("R_nc4_blankstring", as.integer(n), PACKAGE="easyNCDF")
return( rv )
}
.ncvar_type_to_string <- function( precint ) {
if( precint == 1 )
prec <- "short"
else if( precint == 2 )
prec <- "int"
else if( precint == 3 )
prec <- "float"
else if( precint == 4 )
prec <- "double"
else if( precint == 5 )
prec <- "char"
else if( precint == 6 )
prec <- "byte"
else if( precint == 7 )
prec <- "unsigned byte"
else if( precint == 8 )
prec <- "unsigned short"
else if( precint == 9 )
prec <- "unsigned int"
else if( precint == 10 )
prec <- "8 byte int"
else if( precint == 11 )
prec <- "unsinged 8 byte int"
else if( precint == 12 )
prec <- "string"
else
stop(paste("Error, unrecognized type code of variable supplied:", precint ))
return( prec )
}
.ncvar_get_inner <- function( ncid, varid, missval, addOffset=0., scaleFact=1.0, start=NA, count=NA, verbose=FALSE, signedbyte=TRUE,
collapse_degen=TRUE, raw_datavals=FALSE ) {
if( ! is.numeric(ncid))
stop("Error, first arg passed to ncvar_get_inner (ncid) must be a simple C-style integer that is passed directly to the C api")
if( ! is.numeric(varid))
stop("Error, second arg passed to ncvar_get_inner (varid) must be a simple C-style integer that is passed directly to the C api")
if( verbose ) {
print(paste("ncvar_get_inner: entering with (C-STYLE INTEGER ONLY) ncid=", ncid,
"varid=", varid ))
print(paste("ncvar_get_inner: following line is collapse_degen:"))
print(collapse_degen)
}
tmp_typename = c('short', 'int', 'float', 'double', 'char', 'byte' )
have_start = (length(start)>1) || ((length(start)==1) && (!is.na(start)))
have_count = (length(count)>1) || ((length(count)==1) && (!is.na(count)))
sm <- storage.mode(start)
if( (sm != "double") && (sm != "integer") && (sm != "logical"))
stop(paste("passed a start argument of storage mode",sm,"; can only handle double or integer"))
sm <- storage.mode(count)
if( (sm != "double") && (sm != "integer") && (sm != "logical"))
stop(paste("passed a 'count' argument with storage mode '",sm,"'; can only handle double or integer", sep=''))
if( signedbyte )
byte_style = 1 # 1=signed
else
byte_style = 2 # 2=unsigned
varsize <- .ncvar_size ( ncid, varid )
ndims <- .ncvar_ndims( ncid, varid )
if( verbose ) {
print(paste("ndims:",ndims))
print("ncvar_get: varsize:")
print(varsize)
}
#------------------------------
# Fix up start and count to use
#------------------------------
if( ndims == 0 ) {
start <- 1
count <- 1
}
else
{
if( ! have_start )
start <- rep(1,ndims) # Note: use R convention for now
if( ! have_count )
count <- varsize - start + 1
else
{
#------------------
# Take care of -1's
#------------------
count <- ifelse( (count == -1), varsize-start+1, count)
}
}
if( verbose ) {
print("ncvar_get: start:")
print(start)
print("ncvar_get: count:")
print(count)
}
if( ndims > 0 ) {
if( length(start) != ndims )
stop(paste("Error: variable has",ndims,"dims, but start has",length(start),"entries. They must match!"))
if( length(count) != ndims )
stop(paste("Error: variable has",ndims,"dims, but count has",length(count),"entries. They must match!"))
}
#----------------------------------------
# Need to know how much space to allocate
#----------------------------------------
totvarsize <- prod(count)
if( verbose )
print(paste("ncvar_get: totvarsize:",totvarsize))
#--------------------------------------------------
# Switch from R to C convention for start and count
#--------------------------------------------------
c.start <- start[ ndims:1 ] - 1
c.count <- count[ ndims:1 ]
rv <- list()
rv$error <- -1
#---------------------------------
# Get the correct type of variable
#---------------------------------
precint <- .ncvar_type( ncid, varid ) # 1=short, 2=int, 3=float, 4=double, 5=char, 6=byte, 7=ubyte, 8=ushort, 9=uint, 10=int64, 11=uint64, 12=string
if( verbose )
print(paste("ncvar_get_inner: getting var of type",tmp_typename[precint], 'id=', precint))
if( (precint == 1) || (precint == 2) || (precint == 6) || (precint == 7) || (precint == 8)) {
#--------------------------------
# Short, Int, Byte, UByte, UShort
#--------------------------------
rv <- .Call("Rsx_nc4_get_vara_int",
as.integer(ncid),
as.integer(varid),
as.integer(c.start), # Already switched to C convention...
as.integer(c.count), # Already switched to C convention...
as.integer(byte_style), # 1=signed, 2=unsigned
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("C function Rsx_nc4_get_var_int returned error")
data = rv$data
}
else if( (precint == 3) || (precint == 4)) {
#----------------------------------------------------------------
# Float, double where we have the C routine fix the missing value
# 'imvstate' is: 0 if we do not have a missing value (it is NULL),
# 1 if the missing value is NA, 2 if the missing value is present
# and not NULL and not NA. These codes are used by the C routine
#----------------------------------------------------------------
if( is.null( missval )) {
passed_missval = 0.0
imvstate = as.integer(0)
}
else if( is.na(missval)) {
passed_missval = 0.0
imvstate = as.integer(1)
}
else
{
passed_missval = missval
imvstate = as.integer(2)
}
if( raw_datavals )
fixmiss = as.integer(0) # setting 'raw_datavalues' to TRUE gives the actual raw numbers from the file, not processed at all
else
fixmiss = as.integer(1)
if( verbose ) print('about to call Rsx_nc4_get_vara_double...')
rv <- .Call("Rsx_nc4_get_vara_double",
as.integer(ncid),
as.integer(varid),
as.integer(c.start), # Already switched to C convention...
as.integer(c.count), # Already switched to C convention...
fixmiss,
imvstate,
as.double(passed_missval),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("C function R_nc4_get_vara_double returned error")
if( verbose ) print('back from call to Rsx_nc4_get_vara_double...')
data = rv$data
}
else if( (precint == 9) || (precint == 10) || (precint == 11)) {
#---------------------------------------------
# uint, int64, uint64
# Thanks to Tom Hilinski of Colorado State for
# fix to uint here
#---------------------------------------------
rv$data <- double(totvarsize)
fixmiss = as.integer(0)
rv <- .Call("Rsx_nc4_get_vara_double",
as.integer(ncid),
as.integer(varid),
as.integer(c.start), # Already switched to C convention...
as.integer(c.count), # Already switched to C convention...
fixmiss,
as.integer(-1), # The 'imvstate' arg is unused in this call since no fixmiss
as.double(0.0), # the passed missing value is not used in this call since no fixmiss
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("C function R_nc4_get_vara_double returned error")
data = rv$data
}
else if( precint == 5 ) {
#-----
# Char
#-----
strndims <- ndims - 1
strlen <- count[1] + 1
strdim <- 1
if( strndims >= 1 ) {
strdim <- count[2:ndims]
nstr <- prod(strdim)
}
else
nstr <- 1
if(verbose)
print(paste("ndims:",ndims,"strndims:",strndims,"strlen:",strlen,"nstr:",nstr))
#----------------------------------------------
# Make a character string of the specified size
#----------------------------------------------
stor <- .blankstring_ncdf4( totvarsize )
stordata <- .blankstring_ncdf4(strlen)
if( verbose )
print(paste("length of stor string:",nchar(stor)))
rv$tempstore <- stor
rv$data <- array(stordata, dim=strdim)
rv <- .C("R_nc4_get_vara_text",
as.integer(ncid),
as.integer(varid),
as.integer(c.start), # Already switched to C convention...
as.integer(c.count), # Already switched to C convention...
tempstore=as.character(rv$tempstore),
data=as.character(rv$data),
error=as.integer(rv$error),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop("C function R_nc4_get_var_text returned error")
dim(rv$data) <- strdim
}
else if( precint == 12 ) {
#-----------------------------
# netcdf version 4 String type
#-----------------------------
rv <- .Call( "R_nc4_get_vara_string",
as.integer(ncid),
as.integer(varid),
as.integer(c.start), # Already switched to C convention...
as.integer(c.count), # Already switched to C convention...
PACKAGE="easyNCDF" )
}
else
{
stop(paste("Trying to get variable of an unhandled type code: ",precint, "(", .ncvar_type_to_string(precint), ")"))
}
if( verbose ) {
print(paste("ncvar_get_inner: C call returned",rv$error))
print(paste("ncvar_get_inner: dim of directly returned array:"))
print(dim(rv$data))
}
#--------------------------------------------------------
# Set our dims...but collapse degenerate dimensions first
#--------------------------------------------------------
if( ndims > 0 ) {
if( collapse_degen ) {
count.nodegen <- vector()
foundone <- 0
for( i in 1:ndims )
if( count[i] > 1 ) {
count.nodegen <- append(count.nodegen, count[i])
foundone <- 1
}
if( foundone == 0 )
dim(rv$data) <- (1)
else
{
if( verbose )
print(paste("count.nodegen:",count.nodegen," Length of data:",length(rv$data)))
if( precint != 5 )
dim(rv$data) <- count.nodegen
}
}
else if (precint != 5)
dim(rv$data) = count
if( verbose ) {
print("ncvar_get: final dims of returned array:")
print(dim(rv$data))
}
}
#----------------------------------------------------------
# Change missing values to "NA"s. Note that 'varid2Rindex'
# is NOT filled out for dimvars, so skip this if a dimvar
# 1=short, 2=int, 3=float, 4=double, 5=char, 6=byte
# NOTE: if type is 3 or 4 (float or double), the missing
# value was already set by the C routine.
#----------------------------------------------------------
if( (!raw_datavals) && (precint != 5) && (precint != 3) && (precint != 4) ) { # not char, float, or double
if( verbose ) print("ncvar_get: setting missing values to NA")
if( (precint==1) || (precint==2) || (precint==6) || (precint==7) || (precint==8) || (precint==9)) {
#--------------------------------------
# Short, Int, Byte, UByte, UShort, UInt
#--------------------------------------
if( verbose ) print(paste("ncvar_get_inner: setting ", tmp_typename[precint],"-type missing value of ", missval, " to NA", sep=''))
if( ! is.na(missval) )
rv$data[rv$data==missval] <- NA
}
else if( (precint==10) || (precint==11)) {
#--------------------------------
# 8-byte int, unsigned 8-byte int
#--------------------------------
if( ! is.na(missval) ) {
tol <- abs(missval*1.e-5)
if( verbose ) print(paste("ncvar_get_inner: setting ", tmp_typename[precint],"-type missing value of ", missval,
" (w/tolerance ", tol,") to NA", sep=''))
rv$data[abs(rv$data-missval)<tol] <- NA
}
}
}
#--------------------------------------
# Implement add_offset and scale_factor
#--------------------------------------
if( ! raw_datavals ) {
if( (scaleFact != 1.0) || (addOffset != 0.0) ) {
if( verbose )
print(paste("ncvar_get: implementing add_offset=", addOffset, " and scaleFact=", scaleFact ))
rv$data <- rv$data * scaleFact + addOffset
}
}
return(rv$data)
}
.ncdf4_inner_open <- function( nc ) {
if( class( nc ) != 'ncdf4' )
stop(paste("ncdf4 library: internal error: ncdf4_inner_open called with an object that is NOT class ncdf4!"))
rv <- list()
if( is.null(nc$writable))
stop(paste("Internal error: ncdf4_inner_open called with no $writable element on file", nc$filename))
if( nc$writable )
rv$cmode <- 1
else
rv$cmode <- 0
rv$id <- -1
rv$error <- -1
rv <- .C("R_nc4_open",
as.character(nc$filename),
as.integer(rv$cmode), # write mode=1, read only=0
id=as.integer(rv$id), # note: nc$id is the simple integer ncid of the base file (root group in the file)
error=as.integer(rv$error),
PACKAGE="easyNCDF")
if( rv$error != 0 )
stop(paste("Error in nc_open trying to open file",nc$filename))
return( rv$id )
}
.ncdf4_make_id <- function( id=-1, group_index=-1, group_id=-1, list_index=-1, isdimvar=FALSE ) {
retval <- list( id=id, group_index=group_index, group_id=group_id,
list_index=list_index, isdimvar=isdimvar )
class(retval) <- 'ncid4'
return( retval )
}
.vobjtovarid4 <- function( nc, varid, verbose=FALSE, allowdimvar=TRUE) {
if( verbose )
print(paste("vobjtovarid4: entering"))
if( class(nc) != 'ncdf4' )
stop('First passed argument (nc) must be an object of class ncdf4, as returned by nc_open() or nc_create()')
if( (class(varid) != 'ncvar4') && (class(varid) != 'ncdim4') && (class(varid) != 'ncid4') && (!is.character(varid)) && (!is.na(varid)))
stop('Second passed argument (varid) must be an object of class ncvar4 or ncid4, the character string name of a variable, or a NA (indicating to use the only var in the file)')
#-------------------------------------------------------------
# Easiest case is if we were given a ncid object to begin with
#-------------------------------------------------------------
if( class(varid) == 'ncid4' ) {
if(verbose) print("vobjtovarid4: passed varid was an ncid, easy exit")
return( varid ) # an object of class 'ncid4', not a simple integer
}
#------------------------------------------------------------
# Handle case where we are given a ncvar object to begin with
#------------------------------------------------------------
if( class(varid) == "ncvar4" ) {
origvarid <- varid
if(verbose)
print(paste("vobjtovarid4: passed a ncvar class, name=",varid$name))
varid <- nc$var[[varid$name]]$id # Note we do NOT use varid$id in case var is from different file (but names are same)
if( is.null(varid)) {
print('------------------------------------------------------')
print(paste("Error, var '", origvarid$name,"' was not found in file '", nc$filename, "'", sep=''))
print(paste('Hint: make SURE the variable was not only defined with a call to ncvar_def(), but also included in the list of variables passed to nc_create()'))
stop('stopping')
}
if( class(varid) != 'ncid4' ) {
print('------------------------------')
print("here is varid:")
print(varid)
stop(paste("Internal error #E, returned varid is not a object of class ncid4"))
}
#-----------------------------------------------------------------
# Make sure this varid that will be returned has valid information
#-----------------------------------------------------------------
varidOK <- ((varid$id>=0) && (varid$id<=100000) && (varid$group_id >= 0))
if( is.na(varidOK) || (!varidOK)) {
print("vobjtovarid4: I was passed a ncvar object, BUT this object does NOT refer to any valid var in the netcdf file!")
print(paste("This happened for netCDF filename:",nc$filename))
print("Here are the vars in the netCDF file:")
for( ii in 1:nc$nvars )
print(paste(ii,": ",nc$var[[ii]]$name, sep='' ))
print(paste("The passed varid object (which does NOT exist in that file) is:"))
print(origvarid)
print(paste("Hint: make SURE the variable was not only defined with a call to ncvar_def(), but also included in the list of variables passed to nc_create()"))
stop("stopping")
}
if( verbose )
print(paste("vobjtovarid4: returning with varid deduced from a passed ncvar object; varid=",
varid$group_id, varid$id))
return(varid) # an object of class 'ncid4'
}
#-------------------------------------------------------------
# Handle case where we are given an ncdim object to begin with
#-------------------------------------------------------------
if( class(varid) == "ncdim4" ) {
if( ! allowdimvar )
stop(paste("Error, I was NOT allowed to check dimvars, but the second argument passed was an object of class ncdim4! Name=", varid$name))
if(verbose)
print(paste("vobjtovarid4: passed a ncdim class, name=",varid$name))
#-----------------------------------------------------------
# Go through and find if there is a dim in the file that has
# the same name as this dim. We do not immediately use
# this dim's dimvarid in case the dim is from a different
# file but has the same name.
#-----------------------------------------------------------
name2find = varid$name
foundit = FALSE
for( idim in 1:nc$ndims ) {
if( nc$dim[[idim]]$name == name2find ) {