Utils.R

.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
}

# This function is a copy of the function ncvar_get_inner in 'ncdf4' package 
# with a bugfix. When ncdf4 addresses this bug, this function will be removed
# from this package.
.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 <- ncdf4:::ncvar_size ( ncid, varid )
	ndims   <- ncdf4:::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 <- ncdf4:::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="ncdf4")
		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="ncdf4")
		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="ncdf4")
		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     <- ncdf4:::blankstring_ncdf4( totvarsize )
		stordata <- ncdf4:::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="ncdf4")
		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="ncdf4" )
		}
	else
		{
		stop(paste("Trying to get variable of an unhandled type code: ",precint, "(", ncdf4:::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)
}