.message <- function(...) { # Function to use the 'message' R function with our custom settings # Default: new line at end of message, indent to 0, exdent to 3, # collapse to \n* args <- list(...) ## In case we need to specify message arguments if (!is.null(args[["appendLF"]])) { appendLF <- args[["appendLF"]] } else { ## Default value in message function appendLF <- TRUE } if (!is.null(args[["domain"]])) { domain <- args[["domain"]] } else { ## Default value in message function domain <- NULL } args[["appendLF"]] <- NULL args[["domain"]] <- NULL ## To modify strwrap indent and exdent arguments if (!is.null(args[["indent"]])) { indent <- args[["indent"]] } else { indent <- 0 } if (!is.null(args[["exdent"]])) { exdent <- args[["exdent"]] } else { exdent <- 3 } args[["indent"]] <- NULL args[["exdent"]] <- NULL ## To modify paste collapse argument if (!is.null(args[["collapse"]])) { collapse <- args[["collapse"]] } else { collapse <- "\n*" } args[["collapse"]] <- NULL ## Message tag if (!is.null(args[["tag"]])) { tag <- args[["tag"]] } else { tag <- "* " } args[["tag"]] <- NULL message(paste0(tag, paste(strwrap( args, indent = indent, exdent = exdent ), collapse = collapse)), appendLF = appendLF, domain = domain) } .warning <- function(...) { # Function to use the 'warning' R function with our custom settings # Default: no call information, indent to 0, exdent to 3, # collapse to \n args <- list(...) ## In case we need to specify warning arguments if (!is.null(args[["call."]])) { call <- args[["call."]] } else { ## Default: don't show info about the call where the warning came up call <- FALSE } if (!is.null(args[["immediate."]])) { immediate <- args[["immediate."]] } else { ## Default value in warning function immediate <- FALSE } if (!is.null(args[["noBreaks."]])) { noBreaks <- args[["noBreaks."]] } else { ## Default value warning function noBreaks <- FALSE } if (!is.null(args[["domain"]])) { domain <- args[["domain"]] } else { ## Default value warning function domain <- NULL } args[["call."]] <- NULL args[["immediate."]] <- NULL args[["noBreaks."]] <- NULL args[["domain"]] <- NULL ## To modify strwrap indent and exdent arguments if (!is.null(args[["indent"]])) { indent <- args[["indent"]] } else { indent <- 0 } if (!is.null(args[["exdent"]])) { exdent <- args[["exdent"]] } else { exdent <- 3 } args[["indent"]] <- NULL args[["exdent"]] <- NULL ## To modify paste collapse argument if (!is.null(args[["collapse"]])) { collapse <- args[["collapse"]] } else { collapse <- "\n!" } args[["collapse"]] <- NULL ## Warning tag if (!is.null(args[["tag"]])) { tag <- args[["tag"]] } else { tag <- "! Warning: " } args[["tag"]] <- NULL warning(paste0(tag, paste(strwrap( args, indent = indent, exdent = exdent ), collapse = collapse)), call. = call, immediate. = immediate, noBreaks. = noBreaks, domain = domain) } # This function is a helper for the function .MergeArrays. # It expects as inputs two named numeric vectors, and it extends them # with dimensions of length 1 until an ordered common dimension # format is reached. .MergeArrayDims <- function(dims1, dims2) { new_dims1 <- c() new_dims2 <- c() while (length(dims1) > 0) { if (names(dims1)[1] %in% names(dims2)) { pos <- which(names(dims2) == names(dims1)[1]) dims_to_add <- rep(1, pos - 1) if (length(dims_to_add) > 0) { names(dims_to_add) <- names(dims2[1:(pos - 1)]) } new_dims1 <- c(new_dims1, dims_to_add, dims1[1]) new_dims2 <- c(new_dims2, dims2[1:pos]) dims1 <- dims1[-1] dims2 <- dims2[-c(1:pos)] } else { new_dims1 <- c(new_dims1, dims1[1]) new_dims2 <- c(new_dims2, 1) names(new_dims2)[length(new_dims2)] <- names(dims1)[1] dims1 <- dims1[-1] } } if (length(dims2) > 0) { dims_to_add <- rep(1, length(dims2)) names(dims_to_add) <- names(dims2) new_dims1 <- c(new_dims1, dims_to_add) new_dims2 <- c(new_dims2, dims2) } list(new_dims1, new_dims2) } # This function takes two named arrays and merges them, filling with # NA where needed. # dim(array1) # 'b' 'c' 'e' 'f' # 1 3 7 9 # dim(array2) # 'a' 'b' 'd' 'f' 'g' # 2 3 5 9 11 # dim(.MergeArrays(array1, array2, 'b')) # 'a' 'b' 'c' 'e' 'd' 'f' 'g' # 2 4 3 7 5 9 11 .MergeArrays <- function(array1, array2, along) { if (!(identical(names(dim(array1)), names(dim(array2))) && identical(dim(array1)[-which(names(dim(array1)) == along)], dim(array2)[-which(names(dim(array2)) == along)]))) { new_dims <- .MergeArrayDims(dim(array1), dim(array2)) dim(array1) <- new_dims[[1]] dim(array2) <- new_dims[[2]] for (j in 1:length(dim(array1))) { if (names(dim(array1))[j] != along) { if (dim(array1)[j] != dim(array2)[j]) { if (which.max(c(dim(array1)[j], dim(array2)[j])) == 1) { na_array_dims <- dim(array2) na_array_dims[j] <- dim(array1)[j] - dim(array2)[j] na_array <- array(dim = na_array_dims) array2 <- abind(array2, na_array, along = j) names(dim(array2)) <- names(na_array_dims) } else { na_array_dims <- dim(array1) na_array_dims[j] <- dim(array2)[j] - dim(array1)[j] na_array <- array(dim = na_array_dims) array1 <- abind(array1, na_array, along = j) names(dim(array1)) <- names(na_array_dims) } } } } } array1 <- abind(array1, array2, along = which(names(dim(array1)) == along)) 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)=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 ) { #------------------------------------------- # Remember we return the DIMVAR, not the dim #------------------------------------------- retval = nc$dim[[idim]]$dimvarid # an object of type 'ncid' foundit = TRUE break } } if( ! foundit ) #----------------------------------------------------------- # Return an ncid that indicates this is a dimvar but it does # not exist in the file #----------------------------------------------------------- retval = .ncdf4_make_id( id=-1, group_index=-1, group_id=-1, list_index=-1, isdimvar=TRUE ) if( class(retval) != 'ncid4' ) stop(paste("Internal error #C, returned varid is not a object of class ncid4. Case with ncdim object passed; ncdim name=", varid$name)) if( verbose ) print(paste("vobjtovarid4: returning with varid deduced from a passed ncvar object; retval=", retval$group_id, retval$id)) return(retval) # an object of class 'ncid4' } #---------------------------------------------------------- # If we get here, 'varid' can be a NA or a character string #---------------------------------------------------------- #--------------------------------------------------------------------------- # If varid is NA, then return the only var in the file (if there IS only one # var in the file). If there is more than one var in the file, return the # one with the most dimensions, IF that highest-dimensionality var has more # dimensions than any other var in the file. Otherwise, generate an error. #--------------------------------------------------------------------------- if( (length(varid)==1) && is.na(varid)) { if( nc$nvars == 1 ) { varToUse <- 1 } else { #------------------------------------------------------------ # Choose the most complicated var, if there is one, otherwise # halt with an error #------------------------------------------------------------ varToUse <- -1 ndimsItHas <- -1 for( ii in 1:nc$nvars ) { if( nc$var[[ii]]$ndims > ndimsItHas ) { varToUse <- ii ndimsItHas <- nc$var[[ii]]$ndims } } for( ii in 1:nc$nvars ) { if( (ii != varToUse) && (nc$var[[ii]]$ndims == ndimsItHas)) { stop(paste("File",nc$filename,"has more than one variable, so you must explicitly specify which one you want")) } } } varid <- nc$var[[varToUse]]$id # remember, an object of class 'ncid4', not a simple int if( class(varid) != 'ncid4' ) stop(paste("internal error #B, returned varid is not of class ncid4")) if( verbose ) print(paste("vobjtovarid4: returning with only var in file; id=", nc$var[[varToUse]]$id$group_id, nc$var[[varToUse]]$id$id)) return( varid ) # an object of class 'ncid4' } #--------------------------------------------------- # If we get here, 'varid' must be a character string #--------------------------------------------------- if( ! is.character(varid)) stop("internal error: location #M: varid is not a character string!") origvarid <- varid #------------------------------------------- # Make sure var name follows our conventions #------------------------------------------- if( substr(varid,1,1) == '/' ) stop(paste("Error, I was given a name that starts with a slash; fully qualified names NEVER start with a slash (this is required for backwards compatability). Leave off the leading slash!")) #-------------------------------------------- # See if any vars in this file have this name #-------------------------------------------- varToUse <- -1 if( nc$nvars > 0 ) { for( kk in 1:nc$nvars ) { if( origvarid == nc$var[[kk]]$name ) # check to see if fully qualified name matches varToUse <- kk } } #--------------------------------- # Found a var with the right name, # return its ncid object #--------------------------------- if( varToUse != -1 ) { if(verbose) print(paste("Variable named",origvarid,"found in file with varid=", nc$var[[varToUse]]$id$group_id, nc$var[[varToUse]]$id$id)) varid <- nc$var[[varToUse]]$id # remember, an object of class 'ncid4', not a simple int if( class(varid) != 'ncid4' ) { print('---- varid:') print(varid) stop(paste("internal error #A, returned varid is not of class ncid4")) } return( varid ) # an object of class 'ncid4' } #--------------------------------------------------------------- # A var with this name was NOT found in the file. But, it could # be the name of a dimvar in the file. Check to see if we are # allowed to return dimvars in this case. #--------------------------------------------------------------- if( ! allowdimvar ) { print("vobjtovarid4: error #G: I could not find the requested var in the file!") print(paste("requested var name:",origvarid)) print(paste("file name:",nc$filename)) print("Note: I was NOT allowed to check to see if this was a dimvar name") stop("Variable not found") } if(verbose) print(paste("Variable named",origvarid,"NOT found in file; looking for a dimvar with this name")) #----------------------------------------------- # Check to see if passed name matches a dim name #----------------------------------------------- for( i in 1:nc$ndims ) { if( origvarid == nc$dim[[i]]$name ) { #--------------------- # Yes, it IS a dimvar! #--------------------- varid <- nc$dim[[i]]$dimvarid # note: an object of class 'ncid4'. $id will be -1 if there is no dimvar if( class(varid) != 'ncid4' ) stop(paste("Internal error #D, returned varid is not a object of class ncid4")) if( verbose ) print(paste("vobjtovarid4: returning with DIMvarid deduced from name; varid=", varid$group_id, varid$id)) return(varid) # an object of class 'ncid4' } } #------------------------------------------------------------ # If we get here, no dimvar with the requested name was found #------------------------------------------------------------ print("vobjtovarid4: error #F: I could not find the requsted var (or dimvar) in the file!") print(paste("var (or dimvar) name:",origvarid)) print(paste("file name:",nc$filename)) stop("Variable not found") } .ncvar_id_hier <- function( ncid, varname ) { if( mode(ncid) != 'numeric' ) stop("error, must be passed a numeric first arg: ncid2use") if( mode(varname) != 'character' ) stop("Error, must be passed a character second arg: varname" ) rv <- list() rv$varid <- -1 rv$groupid <- -1 rv <- .C("R_nc4_inq_varid_hier", as.integer(ncid), as.character(varname), groupid=as.integer(rv$groupid), varid=as.integer(rv$varid), PACKAGE="easyNCDF") retval = c( rv$varid, rv$groupid ) return( retval ) } .default_missval_ncdf4 <- function() { return(1.e30) } .ncvar_get <- function( nc, varid=NA, start=NA, count=NA, verbose=FALSE, signedbyte=TRUE, collapse_degen=TRUE, raw_datavals=FALSE ) { if( class(nc) != "ncdf4" ) stop("first argument (nc) is not of class ncdf4!") if( verbose ) print(paste("ncvar_get: entering for read from file", nc$filename)) if( (mode(varid) != 'character') && (class(varid) != 'ncvar4') && (class(varid) != 'ncdim4') && (! is.na(varid))) stop(paste("Error: second argument to ncvar_get must be an object of type ncvar or ncdim", "(both parts of the ncdf object returned by nc_open()), the character-string name of a variable or dimension", "or NA to get the default variable from the file. If the file is netcdf version 4", "format and uses groups, then the fully qualified var name must be given, for", "example, model1/run5/Temperature")) #---------------------------------------------------- # If we are running in safemode, must reopen the file #---------------------------------------------------- if( nc$safemode ) { if( verbose ) print(paste("ncvar_get: safemode opening file")) nc$id = .ncdf4_inner_open( nc ) } idobj = .vobjtovarid4( nc, varid, verbose=verbose, allowdimvar=TRUE ) have_start = (length(start)>1) || ((length(start)==1) && (!is.na(start))) have_count = (length(count)>1) || ((length(count)==1) && (!is.na(count))) #----------------------------------------------------------------- # If we have a start or count, they must not have any NA's in them #----------------------------------------------------------------- if( have_start ) { for( i in 1:length(start)) { if( is.na(start[i])) stop(paste("Error, passed a 'start' argument that has NA values:", paste(start,collapse=' ') )) } } if( have_count ) { for( i in 1:length(count)) { if( is.na(count[i])) stop(paste("Error, passed a 'count' argument that has NA values:", paste(count,collapse=' ') )) } } #--------------------------------------------------------------------- # Special check: if we are trying to get values from a dimvar, but the # dim does not have a dimvar, then just return 1:length(dim) #--------------------------------------------------------------------- if( idobj$isdimvar ) { if( verbose ) print(paste("ncvar_get: passed object is a dimvar")) if( idobj$id == -1 ) { # this happens if dim name was passed, but it has no dimvar #-------------------------------------------------------- # Here we return default integers for dims with no dimvar #-------------------------------------------------------- if( ! have_start ) start <- 1 if( ! have_count ) count <- nc$dim[[idobj$list_index]]$len if( count == 1 ) return( start ) else return( start:(start+count-1) ) } else { #----------------------------------------------------------- # Dimvars do not have list_index set, since dimvars do not # appear on the global var list. However, dimvars should # also not have missing values, addOffsets, or scaleFactors, # so this is easy #----------------------------------------------------------- return( .ncvar_get_inner( idobj$group_id, idobj$id, .default_missval_ncdf4(), start=start, count=count, verbose=verbose, signedbyte=signedbyte )) } } else { if( verbose ) print(paste("ncvar_get: passed object is NOT a dimvar")) } #-------------------------------------------- # Get var's missval, addOffset, and scaleFact #-------------------------------------------- if( verbose ) print(paste("ncvar_get: getting add offset and scale fact")) if( idobj$list_index == -1 ) { print("internal error: list_index for var is -1!") print("Here is passed varid:") print(varid) } li = idobj$list_index if( verbose ) { print(paste("ncvar_get: netcdf file index of var on list:", li)) print(paste("ncvar_get: here is var object:")) print(nc$var[[li]]) } if( nc$var[[li]]$hasAddOffset ) addOffset = nc$var[[li]]$addOffset else addOffset = 0; if( nc$var[[li]]$hasScaleFact ) scaleFact = nc$var[[li]]$scaleFact else scaleFact = 1.0; ncid2use = idobj$group_id varid2use = idobj$id if( verbose ) print(paste("ncvar_get: ncid2use=", ncid2use, "varid2use=", varid2use, "missval=", nc$var[[li]]$missval )) #----------------------------------------------------------- # If we are in safe mode, must renew our group id and var id #----------------------------------------------------------- if( nc$safemode ) { if(verbose) print(paste('ncvar_get: file is in safe mode, so reopening file', nc$filename)) nc$id = .ncdf4_inner_open( nc ) c_varid_gid = .ncvar_id_hier( nc$id, nc$var[[li]]$name ) varid2use = c_varid_gid[1] ncid2use = c_varid_gid[2] if(verbose) print(paste('ncvar_get: safe mode renewed ncid, varid2use:', ncid2use, varid2use )) } rv = .ncvar_get_inner( ncid2use, varid2use, nc$var[[li]]$missval, addOffset, scaleFact, start=start, count=count, verbose=verbose, signedbyte=signedbyte, collapse_degen=collapse_degen, raw_datavals=raw_datavals ) #---------------------------------------------------------------- # If we are running in safe mode, close the file before returning #---------------------------------------------------------------- if( nc$safemode ) { trv = .C("R_nc4_close", as.integer(nc$id), PACKAGE="easyNCDF") nc$id = -1 # invalidate this ID since it's not valid any more (duh) } return( rv ) }