Nothing
#===============================================================
# FOR INTERNAL USE ONLY.
# ASSUMES nc and varid are simple C-style integers.
# Set varid to -1 to get the global # of atts.
#
ncatt_get_n <- function( nc, varid ) {
verbose = FALSE
if( verbose ) print(paste("ncatt_get_n: entering with integer (ONLY) nc=", nc, "and integer (ONLY) varid=",varid))
if( ! is.numeric(nc))
stop(paste("error, first arg must be of class ncdf4!"))
if( ! is.numeric(varid))
stop(paste("Error, second arg must be an integer!"))
if( varid == -1 ) {
if( verbose ) print ("ncatt_get_n: varid == -1, so getting number of global attributes")
rv <- list()
rv$ndims <- -1
rv$nvars <- -1
rv$natts <- -1
rv$error <- -1
rv <- .C("R_nc4_inq",
as.integer(nc),
ndims=as.integer(rv$ndims),
nvars=as.integer(rv$nvars),
natts=as.integer(rv$natts),
## REMOVE unlimdimid=as.integer(rv$unlimdimid),
error=as.integer(rv$error),
PACKAGE="ncdf4")
if( rv$error != 0 )
stop(paste("R_nc4_inq returned error on file",nc$filename,"!"))
}
else
{
if( verbose ) print ("ncatt_get_n: varid != -1, so getting number of attributes for a specific var")
str.nc.max.name <- "12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678"
rv <- list()
rv$name <- str.nc.max.name
rv$varlen <- -1
rv$error <- -1
rv$type <- -1
rv$ndims <- -1
rv$natts <- -1
rv$precint <- -1
rv$dimids <- integer(ncvar_ndims( nc, varid ))
rv <- .C("R_nc4_inq_var",
as.integer(nc),
as.integer(varid),
name=as.character(rv$name),
type=as.integer(rv$type),
ndims=as.integer(rv$ndims),
dimids=as.integer(rv$dimids),
natts=as.integer(rv$natts),
precint=as.integer(rv$precint),
error=as.integer(rv$error),
PACKAGE="ncdf4")
if( rv$error != 0 )
stop(paste("R_nc4_inq_var returned error on file",nc$filename,"!"))
}
return( rv$natts )
}
#======================================================================================================
# Args ncid and varid passed to this routine must be simple integers that can be directly
# passed to the C API. I.e., 0-based counting, and a global attribute is flagged by -1.
# NOTE: putting a global attribute is flagged by varid == -1 (NOT zero, since args passed to this
# function must be the C API values, not the R values!)
#
ncatt_put_inner = function( ncid, varid, attname, attval, prec=NA, verbose=FALSE, definemode=FALSE ) {
if( verbose ) print(paste('ncatt_put_inner: entering with ncid=', ncid, 'varid=', varid, 'attname=', attname, 'attval=', attval, 'prec=', prec, 'storage.mode(attval)=', storage.mode(attval) ))
if( ! is.numeric(ncid))
stop("Can only be called with a simple C-style (0-based counting) integer ncid")
if( ! is.numeric(varid))
stop("Can only be called with a simple C-style (0-based counting) integer varid")
if( is.null(attval)) {
print(paste("Warning: ncatt_put passed a NULL attribute; name=", attname ))
return()
}
#-------------------------------------------------------------
# Note there are TWO types here. One is the storage mode
# of the passed attval. The netCDF routine to call is based
# on this stoarge mode. The second type is the type of
# attribute to create. This is passed as the 'prec' parameter
# to this netcDF routine. If the passed prec is NA, then
# the storage mode of the attval is used as the type of the
# attribute to create.
#-------------------------------------------------------------
#-------------------------------------------------------------
# Get the type of attribute to create. This follows the var's
# type, in general, but can be manually overridden.
#-------------------------------------------------------------
atttypeShort <- 1 # These MUST match the values in the C code
atttypeInt <- 2
atttypeFloat <- 3
atttypeDbl <- 4
atttypeText <- 5
atttypeByte <- 6
typetocreate <- -1
if( (length(prec)==1) && is.na(prec) ) {
if( verbose ) print(paste("ncatt_put_inner: no user-specified att type was given, figuring it out..."))
#---------------------------------------------------------------------------
# The logic of this code is as follows. In general, given no additional
# information, it would be nice for the attribute to be the same type as
# the original variable IF POSSIBLE. Now, if we are given a global
# attribute, there is no "original variable", so we just take the precision
# (type) of the attribute as it is. If there IS a variable, we would like
# to make the att the same type if they are "compatible" types. For example,
# if the var is an int and the passed att is 52.0, it would be nice to
# store it as an int rather than as a float. This code attempts to
# make that decision. In general, this only applies if we are trying to
# cast near-integer floats or doubles to int in the case of an int var.
#---------------------------------------------------------------------------
if( varid == -1 ) # A global attribute
prec <- storage.mode(attval)
else if( storage.mode(attval) == "character" ) {
prec <- "character" # This always works, but MAY be inconvenient. However the user passed a char, so honor that request!
}
else
{
prec = storage.mode(attval) # our default choice
#----------------------------------------------------------------
# Get the prec (type) of the VARIABLE this att is associated with
#----------------------------------------------------------------
var_precint = ncvar_type( ncid, varid )
var_prec = ncvar_type_to_string( var_precint )
if( var_prec == "int" ) {
att_is_int = (is.numeric(attval) && (floor(attval) == attval))
if( att_is_int )
prec = 'int'
}
}
if( verbose ) print(paste("ncatt_put_inner: using deduced attribute prec of", prec))
}
else
if( verbose ) print(paste("ncatt_put_inner: using specified attribute prec of", prec))
if( verbose ) print(paste("ncatt_put_inner: prec to create:",prec))
if( (prec == "single") || (prec == "float"))
typetocreate <- atttypeFloat
else if( prec == "short" )
typetocreate <- atttypeShort
else if( prec == "byte" )
typetocreate <- atttypeByte
else if( prec == "double" )
typetocreate <- atttypeDbl
else if( (prec == "integer" ) || (prec == "int"))
typetocreate <- atttypeInt
else if( (prec == "text") || (prec == "character") || (prec == "char"))
typetocreate <- atttypeText
else
stop(paste("Error in ncatt_put: unknown prec type specified:",prec,". Known values: short integer float double character"))
if( ! definemode )
nc_redef(ncid)
#---------------------------------------------------------
# Get the netCDF function to call ... this always depends
# exclusively on the storage mode of the attval
#---------------------------------------------------------
rv <- list()
rv$error <- -1
if( storage.mode(attval) == "integer" ) {
rv <- .C("R_nc4_put_att_int",
as.integer(ncid),
as.integer(varid),
as.character(attname),
as.integer(typetocreate),
as.integer(length(attval)),
attval,
error=as.integer(rv$error),
PACKAGE="ncdf4",
NAOK=TRUE )
if( rv$error != 0 ) {
print(paste("Error in ncatt_put, while writing attribute",
attname,"with value",attval))
stop(paste("Error return from C call R_nc4_put_att_int for attribute",attname))
}
}
else if( storage.mode(attval) == "double" ) {
rv <- .C("R_nc4_put_att_double",
as.integer(ncid),
as.integer(varid),
as.character(attname),
as.integer(typetocreate),
as.integer(length(attval)),
attval,
error=as.integer(rv$error),
PACKAGE="ncdf4",
NAOK=TRUE )
if( rv$error != 0 ) {
print(paste("Error in ncatt_put, while writing attribute",
attname,"with value",attval))
stop(paste("Error return from C call R_nc4_put_att_double for attribute",attname))
}
}
else if( storage.mode(attval) == "character") {
if( verbose )
print(paste0("Calling R_nc4_put_att_text with name >", attname, "< att_len: ",
as.integer(length(attval)), ' value: >', attval, '<' ))
rv <- .C("R_nc4_put_att_text",
as.integer(ncid),
as.integer(varid),
as.character(attname),
as.integer(typetocreate),
as.integer(length(attval)),
attval,
error=as.integer(rv$error),
PACKAGE="ncdf4",
NAOK=TRUE )
if( rv$error != 0 ) {
print(paste("Error in ncatt_put, while writing attribute",
attname,"with value",attval))
stop(paste("Error return from C call R_nc4_put_att_text for attribute",attname))
}
}
else if( storage.mode(attval) == "logical") {
rv <- .C("R_nc4_put_att_logical",
as.integer(ncid),
as.integer(varid),
as.character(attname),
as.integer(typetocreate),
as.integer(length(attval)),
attval,
error=as.integer(rv$error),
PACKAGE="ncdf4",
NAOK=TRUE )
if( rv$error != 0 ) {
print(paste("Error in ncatt_put, while writing attribute",
attname,"with value",attval))
stop(paste("Error return from C call R_nc4_put_att_logical for attribute",attname))
}
}
else
stop(paste("ncatt_put: error, passed an attribute with a storage mode not handled. Att name:",attname,"Att value:",attval,"Storage mode passed:",storage.mode(attval),". Handled types: integer double character"))
if( ! definemode ) {
if( nc_enddef( ncid ) != 0 )
stop(paste("Error, nc_enddef returned an error!"))
}
}
#===================================================================================================
# The difference between the "inner" version and the "regular" version is that the inner
# version is passed only simple C-style integer ID's to operate on.
# Inputs:
# ncid, varid: C-style (0-based counting) integers. ncid must actually be a group
# ID if appropriate.
#
# SPECIAL NOTE:: Ordinarily, the C interface uses a varid == -1 to indicate global attributes.
# while the R code visible to the user indicates global attributes using a varid == 0. Since this
# routine takes as its input the actual C-style numbers, the passed varid must equal -1 to access
# global attributes.
#
ncatt_get_inner <- function( ncid, varid, attname=NA, verbose=FALSE ) {
if( verbose ) print(paste("ncatt_get_inner: entering with ncid=", ncid, "varid=", varid, "attname=", attname ))
if( ! is.numeric(ncid))
stop(paste("ncatt_get_inner must be passed a simple C-style (0-based counting) integer as the first argument (ncid)"))
if( ! is.numeric(varid))
stop(paste("ncatt_get_inner must be passed a simple C-style (0-based counting) integer as the first argument (ncid)"))
retval <- list()
#---------------------------------------------------------------------------
# If no attname is specified, return a list with attribute name/value pairs
#---------------------------------------------------------------------------
if( is.na(attname)) {
if( verbose ) print(paste("ncatt_get_inner: no attname specified, returning a list with name/value pairs *******"))
na <- ncatt_get_n( ncid, varid )
if( verbose ) print(paste("ncatt_get_inner: number of atts for this var [or file, if global]:", na))
if( na == 0 ) {
if( verbose ) print(paste("ncatt_get_inner: no attributes for this var/file, returning empty list"))
return( retval )
}
if( verbose ) print(paste("ncatt_get_inner: Looping over",na,"attributes ******"))
for( iatt in 0:(na-1) ) { # NOTE C-style 0-based counting here
#---------------------
# Get attribute's name
#---------------------
str.nc.max.name <- "12345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678"
rv0 <- list()
rv0$error <- -1
rv0$attname <- str.nc.max.name
rv0 <- .C("R_nc4_inq_attname",
as.integer(ncid),
as.integer(varid),
as.integer(iatt),
attname=as.character(rv0$attname),
error=as.integer(rv0$error),
PACKAGE="ncdf4")
if( rv0$error != 0 ) {
stop("error on call to R_nc4_inq_attname")
}
if( verbose ) print(paste("ncatt_get_inner: Attribute", iatt, "(in 0-based counting) has name \"", rv0$attname, "\"" ))
#-------------------------------------------------------------------------------
# Get attribute's value by recursively calling myself with the name now supplied
#-------------------------------------------------------------------------------
if( verbose ) print(paste("ncatt_get_inner: recursively calling myself to value for attribute \"", rv0$attname, "\"" ))
tt <- ncatt_get_inner( ncid, varid, rv0$attname )
if( ! tt$hasatt )
stop(paste("internal error: could not get attribute value for att named ", rv0$attname ))
retval[[rv0$attname]] <- tt$value
}
if( verbose ) print(paste("ncatt_get_inner: done, returning a list with name/value pairs *******"))
return( retval )
}
#----------------------------------------------------
# Find out if the attribute exists for this variable,
# and, if so, what type and length it is.
#----------------------------------------------------
rv0 <- list()
rv0$error <- -1
rv0$attlen <- -1
rv0$type <- -1
if( verbose ) print("ncatt_get_inner: about to call R_nc4_inq_att")
rv0 <- .C("R_nc4_inq_att",
as.integer(ncid),
as.integer(varid),
as.character(attname),
type=as.integer(rv0$type), # 1=short 2=int 3=float 4=double 5=text 6=byte 7=ubyte 8=ushort 9=uint 10=int64 11=uint64 12=string
attlen=as.integer(rv0$attlen),
error=as.integer(rv0$error),
PACKAGE="ncdf4")
if( verbose ) print(paste("ncatt_get_inner: R_nc4_inq_att returned with error=", rv0$error, "type=", rv0$type))
if( rv0$error != 0 ) {
#---------------------------------------------------------
# This variable did NOT have an attribute named 'attname',
# or it is of a type not handled.
#---------------------------------------------------------
retval$hasatt <- FALSE
retval$value <- 0
return(retval)
}
retval$hasatt <- TRUE
rv <- list()
rv$error <- -1
if ( rv0$type %in% c( 1, 2, 6, 7, 8 ) ) {
#--------------------------------
# Short, Int, Byte, UByte, UShort
#--------------------------------
rv$attribute <- rep(as.integer(0),rv0$attlen)
if( verbose ) print(paste("ncatt_get_inner: calling R_nc4_get_att_int"))
rv <- .C("R_nc4_get_att_int",
as.integer(ncid),
as.integer(varid),
as.character(attname),
attribute=as.integer(rv$attribute),
error=as.integer(rv$error),
PACKAGE="ncdf4")
}
else if ( rv0$type %in% c( 3, 4, 9, 10, 11 ) ) {
if( (rv0$type == 10) || (rv0$type == 11)) {
print(paste(">>>> WARNING <<< attribute", attname, "is an 8-byte value, but R"))
print(paste("does not support this data type. I am returning a double precision"))
print(paste("floating point, but you must be aware that this could lose precision!"))
}
#------------------------------------------------------
# Single, Double, 8-byte int, unsigned 8-byte int, UInt
# Thanks to Tom Hilinski at Colorado State for fix to
# uint in earlier versions.
#------------------------------------------------------
rv$attribute <- rep(0.0,rv0$attlen)
if( verbose ) print(paste("ncatt_get_inner: calling R_nc4_get_att_double"))
rv <- .C("R_nc4_get_att_double",
as.integer(ncid),
as.integer(varid),
as.character(attname),
attribute=as.double(rv$attribute),
error=as.integer(rv$error),
PACKAGE="ncdf4")
}
else if( rv0$type == 5 ) {
#-------------------------------------------------
# "Text" ... note we allocate storage for it first
#-------------------------------------------------
rv$attribute <- blankstring_ncdf4( rv0$attlen )
if( verbose ) print(paste("ncatt_get_inner: calling R_nc4_get_att_text"))
rv <- .C("R_nc4_get_att_text",
as.integer(ncid),
as.integer(varid),
as.character(attname),
attribute=as.character(rv$attribute),
error=as.integer(rv$error),
PACKAGE="ncdf4")
}
else if( rv0$type == 12 ) {
#----------------------------------------------------
# "String" ... strings are very different from "text"
# because the reported "attlen" will be the number
# of strings, rather than the length of any string.
#----------------------------------------------------
error = as.integer(0)
if( verbose ) print(paste("ncatt_get_inner: calling R_nc4_get_att_string"))
attribute <- .Call("R_nc4_get_att_string",
as.integer(ncid),
as.integer(varid),
as.character(attname),
as.integer(rv0$attlen), # number of strings to return
error,
PACKAGE="ncdf4")
rv = list( error=error, attribute=attribute )
}
else
stop(paste("error, unhandled attribute type:", rv0$type))
if( verbose ) print(paste("ncatt_get_inner: return value from that call:", rv$error))
if( rv$error != 0 ) {
#---------------------------------------------
# ? Got some strange error -- return as if the
# attribute did not exist
#---------------------------------------------
retval$hasatt <- FALSE
retval$value <- 0
return(retval)
}
retval$value <- rv$attribute
if( verbose ) print(paste("ncatt_get_inner: done for a single attribute, value= >",retval$value,"<"))
return(retval)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.