Commit cdefa2a9 authored by Burkhardt Rockel's avatar Burkhardt Rockel

Repository starts with ncdf4Utils_0.4-10

parents
ncdf4Utils version 0.4-10
-------------------------
initial version in netCDF4 based on netCDF3 version ncdfUtils
Package: ncdf4Utils
Type: Package
Title: provides plot functions to use with NetCDF data
Version: 0.4-10
Date: 2010-11-22
Author: Jonas Bhend <jonas.bhend@env.ethz.ch>, with contributions
from Burkhardt Rockel <burkhardt.rockel@hzg.de>
Maintainer: Jonas Bhend <jonas.bhend@env.ethz.ch>
Depends: R (>= 1.8.0), ncdf4, maps, mapdata, sp, akima
Suggests: udunits
Description: This package contains numerous functions to plot
spatial data on both rotated and regular lonlat grids, as
well as an extension to the functions in ncdf allowing for
NetCDF times to be read into R Date objects.
License: GPL
LazyLoad: yes
LazyData: true
Packaged: Mon November 22 14:11:000 2010; rockel
.data <- t(array(c(
0, 0, 0,
2, 31, 64,
5, 48, 97,
23, 62, 132,
33, 102, 172,
67, 147, 195,
146, 197, 222,
209, 229, 240,
253, 253, 253,
253, 219, 199,
244, 165, 130,
214, 96, 77,
178, 24, 43,
138, 14, 33,
103, 0, 31,
68, 0, 28,
0, 0, 0),
dim=c(3,17)))/255
.hsurf <- t(array(c(
60, 179, 113,
157, 210, 156,
207, 229, 174,
242, 244, 193,
230, 226, 148,
216, 211, 114,
165, 152, 72,
121, 79, 31,
81, 63, 22),
dim=c(3,9)))/255
.gpcc <- t(array(c(
255, 252, 127,
255, 250, 0,
132, 250, 127,
22, 247, 0,
18, 194, 0,
15, 165, 0,
14, 162, 255,
9, 109, 255,
0, 39, 255,
139, 50, 222,
159, 31, 161,
189, 37, 191,
218, 43, 221,
253, 0, 255),
dim=c(3,14)))/255
# define the standard colour bars
.bluewhite <- .data[1:9,]
.redwhite <- .data[17:9,]
.greenwhite <- .data[17:9,c(2,1,3)]
.brownwhite <- .data[1:9,c(3,2,1)]
.water <- "#ABE1FA"
rm(.data)
.getval <- function(ind, val, predind, smooth) {
# Function to get smoothed values in the interval 0 - 1
#
# Arguments:
# ind An index specifying the spacing of the values (0 - 1)
# val The values to which a smoothed spline is fitted
# predind The location for which the smoothed spline function
# is evaluated (0 - 1)
# smooth the smoothing as "spar" in smooth.spline
#
# Author jonas.bhend -at- gkss.de
#
fitfun <- smooth.spline(ind, val, spar=smooth)
fitval <- predict(fitfun, predind)$y
if (min(fitval) < 0) fitval <- fitval - min(fitval)
if (max(fitval) > 1) fitval <- fitval / max(fitval)
fitval
}
.colseq <- function(x, tmp, start=0, stop=1, log=F, smooth=0.4){
# .colseq computes a color sequence of x rgb colors along the indicated
# colors by tmp (Attention: 'ind' is set to .spacing to match the
# colours provided by .bluewhite, etc.)
#
# Arguments:
# x Number of colors
# tmp Array of rgb values (dim=c(ncolors,3)) along which
# the color sequence is interpolated
# start/stop the range for which colours should be interpolated (0 - 1)
# log logical, defaults to FALSE, interval between start
# and stop is divided linearly
# smooth smoothing for smooth.spline in .getval
#
# Author jonas.bhend -at- gkss.de
#
ind <- seq(0,1,length=dim(tmp)[1])
predind <- seq(start, stop, length=x)
if (log & min(predind) > 0){
predind <- log(predind)
mini <- min(predind)
maxi <- max(predind)
predind <- (predind - mini)/(maxi-mini)*(stop-start) + start
}
r <- .getval(ind, tmp[,1], predind, smooth=smooth)
g <- .getval(ind, tmp[,2], predind, smooth=smooth)
b <- .getval(ind, tmp[,3], predind, smooth=smooth)
colour <- rgb(r,g,b)
colour
}
rbfun <- function(x, start=0.4, log=F){
# rbfun computes a symmetric redblue color scale with x colors
#
# Arguments:
# x number of colors
# start 'Darkness' of the darkest colours (0=black, 1=white)
# log logical, defaults to FALSE, if true, colors around the
# center of the color scale get brighter
#
# Author jonas.bhend -at- gkss.de
#
numx <- floor(x/2)
if (2*numx == x){
colour <- c(.colseq((numx+1), .bluewhite, start=start, log=log)[1:numx],
rev(.colseq((numx+1), .redwhite, start=start, log=log)[1:numx]))
} else {
colour <- c(.colseq((numx+1), .bluewhite, start=start, log=log),
rev(.colseq((numx+1), .redwhite, start=start, log=log)[1:numx]))
}
colour
}
gbfun <- function(x, start=0.4, log=F){
# rbfun computes a symmetric greenbrown color scale with x colors
#
# Arguments:
# x number of colors
# start 'Darkness' of the darkest colours (0=black, 1=white)
# log logical, defaults to FALSE, if true, colors around the
# center of the color scale get brighter
#
# Author jonas.bhend -at- gkss.de
#
numx <- floor(x/2)
if (2*numx == x){
colour <- c(.colseq((numx+1), .brownwhite, start=start, log=log)[1:numx],
rev(.colseq((numx+1), .greenwhite, start=start, log=log)[1:numx]))
} else {
colour <- c(.colseq((numx+1), .brownwhite, start=start, log=log),
rev(.colseq((numx+1), .greenwhite, start=start, log=log)[1:numx]))
}
colour
}
.soil <- c("#E6FAFF","white", "grey", gbfun(6)[c(3:1,4:6)], .water)
`frac_in_polygon` <-
function(lon, lat, poly.x, poly.y, multiply=4){
# blow up longitudes
nlon <- length(lon)
lon.alt <- c(lon[1] - 0.5*diff(lon[1:2]), lon,
lon[nlon] + 0.5*diff(lon[nlon - 1:0]))
lon.ind <- c(0,seq(0.5/nlon, 1-0.5/nlon,length=nlon),1)
ind.out <- seq(0.5/nlon/multiply, 1- 0.5/nlon/multiply, length=nlon*multiply)
lon.new <- approx(lon.ind, lon.alt, ind.out)$y
# blow up latitudes
nlat <- length(lat)
lat.alt <- c(lat[1] - 0.5*diff(lat[1:2]), lat,
lat[nlat] + 0.5*diff(lat[nlat - 1:0]))
lat.ind <- c(0,seq(0.5/nlat, 1-0.5/nlat,length=nlat),1)
ind.out <- seq(0.5/nlat/multiply, 1- 0.5/nlat/multiply, length=nlat*multiply)
lat.new <- approx(lat.ind, lat.alt, ind.out)$y
# find points in polygon
outgrid <- point.in.polygon(rep(lon.new, length(lat.new)),
rep(lat.new, each=length(lon.new)), poly.x, poly.y)
if (multiply == 1){
outgrid[outgrid > 1] <- NA
} else {
outgrid[outgrid > 1] <- 0.5
}
out.tmp <- array(outgrid, c(multiply, nlon, multiply, nlat))
fracout <- apply(out.tmp, c(2,4), mean, na.rm=T)
fracout
}
.k2p <- function(v){
if (length(v) == 3){
v <- t(t(v))
}
lon <- atan(v[2,]/v[1,])/pi*180
indi <- v[1,] < 0 & v[2,] < 0 & !is.na(v[1,]) & !is.na(v[2,])
lon[indi] <- lon[indi] - 180
indi <- v[1,] < 0 & v[2,] >= 0 & !is.na(v[1,]) & !is.na(v[2,])
lon[indi] <- lon[indi] + 180
lat <- asin(v[3,])/pi*180
if (length(lat) == 1){
p <- c(lon,lat)
} else {
p <- cbind(lon,lat)
}
p
}
##########################################################
.p2k <- function(lon,lat){
lonr <- lon/180*pi
latr <- lat/180*pi
if (length(lonr) == 1){
v <- c(cos(lonr)*cos(latr),sin(lonr)*cos(latr),sin(latr))
} else {
v <- rbind(cos(lonr)*cos(latr),sin(lonr)*cos(latr),sin(latr))
}
v
}
##########################################################
.phirot2phi <- function(phirot, rlarot, polphi, pollam, polgam=0){
# Description:
# This function converts phi from one rotated system to phi in another
# system. If the optional argument polgam is present, the other system
# can also be a rotated one, where polgam is the angle between the two
# north poles.
# If polgam is not present, the other system is the real geographical
# system.
#
# Method:
# Transformation formulas for converting between these two systems.
#
# convert to -180 to 180
ind <- rlarot > 180 & !is.na(rlarot)
rlarot[ind] <- rlarot[ind] - 360
# convert to -pi to pi
polphi <- polphi / 180 * pi
pollam <- pollam / 180 * pi
polgam <- polgam / 180 * pi
phirot <- phirot / 180 * pi
rlarot <- rlarot / 180 * pi
zsinpol <- sin(polphi)
zcospol <- cos(polphi)
# adjust for switched north pole
if (polgam != 0){
zarg <- zsinpol * sin(phirot) + zcospol * cos(phirot) *
(cos(rlarot)*cos(polgam) - sin(polgam) * sin(rlarot))
} else {
zarg <- zcospol * cos(phirot) * cos(rlarot) + zsinpol * sin(phirot)
}
out <- asin(zarg) * 180 / pi
}
##########################################################
.phi2phirot <- function(phi, rla, polphi, pollam){
#------------------------------------------------------------------------------
# Description:
# This routine converts phi from the real geographical system to phi
# in the rotated system.
#
# Method:
# Transformation formulas for converting between these two systems.
#
#------------------------------------------------------------------------------
zsinpol <- sin(polphi / 180 * pi)
zcospol <- cos(polphi / 180 * pi)
zlampol <- pollam / 180 * pi
zphi <- phi / 180 * pi
ind <- rla > 180 & !is.na(rla)
rla[ind] <- rla[ind] - 360
zrla <- rla / 180 * pi
zarg1 <- sin(zphi) * zsinpol
zarg2 <- cos(zphi) * zcospol * cos(zrla - zlampol)
phi2phirot <- asin(zarg1 + zarg2) * 180 / pi
phi2phirot
}
##########################################################
.rlarot2rla <- function(phirot, rlarot, polphi, pollam, polgam=0){
# Description:
# This function converts lambda from one rotated system to lambda in another
# system. If the optional argument polgam is present, the other system
# can also be a rotated one, where polgam is the angle between the two
# north poles.
# If polgam is not present, the other system is the real geographical
# system.
#
# Method:
# Transformation formulas for converting between these two systems.
#
zpir18 <- pi/180
zrpi18 <- 180/pi
zsinpol <- sin(zpir18 * polphi)
zcospol <- cos(zpir18 * polphi)
zlampol <- zpir18 * pollam
zphis <- zpir18 * phirot
# convert to -180 to 180
ind <- rlarot > 180 & !is.na(rlarot)
rlarot[ind] <- rlarot[ind] - 360
zrlas <- zpir18 * rlarot
if (polgam != 0) {
zgam <- zpir18 * polgam
zarg1 <- sin(zlampol) * (- zsinpol*cos(zphis) * (cos(zrlas)*cos(zgam) -
sin(zrlas)*sin(zgam)) + zcospol * sin(zphis)) - cos(zlampol)*cos(zphis) *
(sin(zrlas)*cos(zgam) + cos(zrlas)*sin(zgam))
zarg2 <- cos(zlampol) * (- zsinpol*cos(zphis) * (cos(zrlas)*cos(zgam) -
sin(zrlas)*sin(zgam)) + zcospol * sin(zphis)) + sin(zlampol)*cos(zphis) *
(sin(zrlas)*cos(zgam) + cos(zrlas)*sin(zgam))
} else {
zarg1 <- sin(zlampol) * (-zsinpol * cos(zrlas) * cos(zphis) + zcospol *
sin(zphis)) - cos(zlampol) * sin(zrlas) * cos(zphis)
zarg2 <- cos(zlampol) * (-zsinpol * cos(zrlas) * cos(zphis) + zcospol *
sin(zphis)) + sin(zlampol) * sin(zrlas) * cos(zphis)
}
zarg2[zarg2 == 0] <- 1.0e-20
rlarot2rla <- zrpi18 * atan2(zarg1, zarg2)
rlarot2rla
}
##########################################################
.rla2rlarot <- function(phi, rla, polphi, pollam, polgam=0) {
#------------------------------------------------------------------------------
#
# Description:
# This routine converts lambda from the real geographical system to lambda
# in the rotated system.
#
# Method:
# Transformation formulas for converting between these two systems.
#
#------------------------------------------------------------------------------
zpir18 <- pi/180
zrpi18 <- 180/pi
zsinpol <- sin(zpir18 * polphi)
zcospol <- cos(zpir18 * polphi)
zlampol <- zpir18 * pollam
zphi <- zpir18 * phi
# convert everything to -180 to 180
ind <- rla > 180 & !is.na(rla)
rla[ind] <- rla[ind] - 360
zrla <- zpir18 * rla
zarg1 <- - sin(zrla-zlampol) * cos(zphi)
zarg2 <- - zsinpol * cos(zphi) * cos(zrla-zlampol) +
zcospol * sin(zphi)
zarg2[zarg2 == 0] <- 1.0e-20
rla2rlarot <- zrpi18 * atan2(zarg1,zarg2)
if (polgam != 0) {
rla2rlarot <- polgam + rla2rlarot
}
ind <- rla2rlarot > 180 & !is.na(rla2rlarot)
rla2rlarot[ind] <- rla2rlarot[ind] - 360
rla2rlarot
}
##########################################################
geo2rot <- function(pollon, pollat, lon, lat, polgam=0){
rlon <- .rla2rlarot(lat, lon, pollat, pollon, polgam)
rlat <- .phi2phirot(lat, lon, pollat, pollon)
out <- list(x=rlon, y=rlat)
out
}
##########################################################
rot2geo <- function(pollon, pollat, rlon, rlat, polgam=0){
lon <- .rlarot2rla(rlat, rlon, pollat, pollon, polgam)
lat <- .phirot2phi(rlat, rlon, pollat, pollon, polgam)
out <- list(x=lon, y=lat)
out
}
This diff is collapsed.
`ncdf_times` <-
function(nc, as.Rdate=TRUE, force=TRUE, tz="CET") {
# this function converts netcdf times to the
# R date-time format or to the udunits dates
# you can choose to switch to uduints format
# for gregorian calendars by setting as.Rdate
# to FALSE
# non-gregorian calendar dates are output using
# udunits date format
# you can force to get back an R date format, even
# if the calendar used is not gregorian using
# force=T (may return udunits dates if conversion
# is not successful)
# WARNING: time zones are not fully supported yet
# check whether udunits is available
.udunitsInclude <- FALSE
if (any(.packages() == "udunits") & class(try(utInit(), silent=T)) != "try-error"){
.udunitsInclude <- TRUE
}
timei <- which(names(nc$dim) %in% c("time", "TIME", "tim", "TIM"))
units <- nc$dim[[timei]]$units
vals <- nc$dim[[timei]]$vals
tmp <- ncatt_get(nc, names(nc$dim)[timei], "calendar")
if (tmp$hasatt) {
calendar <- tmp$value
} else {
calendar <- "standard"
print(paste("Warning: Calendar is missing in", nc$filename))
}
if (calendar == "proleptic_gregorian") calendar <- "standard"
if (as.Rdate & calendar == "standard"){
if (charmatch("hours since", units, nomatch=0) |
charmatch("minutes since", units, nomatch=0) |
charmatch("seconds since", units, nomatch=0)) {
mul <- 1
ref.txt <- substr(units, 15,33)
if (charmatch("minutes", units, nomatch=0)) mul <- 60
if (charmatch("hours", units, nomatch=0)) {
mul <- 3600
ref.txt <- substr(units, 13,31)
}
times <- vals * mul
if (nchar(ref.txt) == 19){
ref <- as.POSIXct(ref.txt, tz)
} else {
ref <- as.POSIXct(paste(ref.txt, "00", sep=":"), tz)
}
time <- as.Date(ref + times)
}
if (charmatch("days since", units, nomatch=0)){
time <- as.Date(substr(units, 12,21), "%Y-%m-%d") + vals
}
if (charmatch("months since", units, nomatch=0)) {
ref.yr <- as.numeric(substr(units, 14,17))
ref.month <- as.numeric(substr(units, 19,20))
ref.day <- as.numeric(substr(units, 22,23))
if (is.null(ref.day)) ref.day <- 1
month <- floor((vals+ref.yr*12 + ref.month-1) %% 12) + 1
year <- floor((vals+ref.yr*12 + ref.month-1)/12)
time <- as.Date(ISOdate(year, month, ref.day))
}
if (charmatch("years since", units, nomatch=0)) {
unit.tmp <- paste(strsplit(units, " ")[[1]][3:4], collapse=" ")
#ref.yr <- substr(units, 13,16)
#ref.month <- as.numeric(substr(units, 18,19))
ref.yr <- as.numeric(format(as.Date(unit.tmp), "%Y"))
ref.month <- as.numeric(format(as.Date(unit.tmp), "%m"))
if (is.null(ref.month)) ref.month <- 1
#ref.day <- as.numeric(substr(units, 21,22))
ref.day <- as.numeric(format(as.Date(unit.tmp), "%d"))
if (is.null(ref.day)) ref.day <- 1
year <- floor(vals)
month <- floor((vals*12)%%12)
time <- as.Date(ISOdate(ref.yr + year, ref.month + month, ref.day))
}
if (charmatch("day as", units, nomatch=0)) {
date <- floor(vals)
day <- as.numeric(substr(date, nchar(date)-1, nchar(date)))
if (all(day > 28)) date <- as.character(as.numeric(date) - max(day, na.rm=T) + 28)
date <- paste("000",date, sep="")
date <- substr(date, nchar(date)-7, nchar(date))
time <- as.Date(date, "%Y%m%d")
}
} else {
if (.udunitsInclude){
time <- utCalendar(vals, units, calendar=calendar, style="array")
if (force){
tmp <- try(ISOdatetime(time$year, time$month, time$day, time$hour,
time$minute, time$second, tz), silent=T)
if (class(tmp)[1] != "try-error") time <- tmp
}
} else {
stop("Package udunits cannot be loaded or initialized via utInit()")
}
}
time
}
`plot_colourbar` <-
function (x, ...){
UseMethod("plot_colourbar")
}
`plot_colourbar.default` <-
function(levs, cols, side=1, ylab="", labels=NULL,
xlab="", nn=1, center=F, cex.axis=1, sea.col=NULL,...){
# plots a colour bar given the levs and cols
# centers the axis labelling instead of at the
# boundary when center==TRUE
# if sea.col is set, the colourbar is prolonged by one
# colour with the uncentered label sea underneath
sea.add <- 0
if (!is.null(sea.col)) {
cols <- c(sea.col, cols)
sea.add <- 1
}
ncols <- length(cols)
lev.arr <- array(1:ncols, c(1, ncols))
if (side %in% c(1,3)){
lev.arr <- t(lev.arr)
}
if (side %in% c(1,3)){
image(1:ncols, 1, lev.arr, axes=F, breaks=1:(ncols+1)-0.5, col=cols,
ylab=ylab, xlab=xlab, ...)
abline(v=1:(ncols-1) + 0.5)
} else {
image(1, 1:ncols, lev.arr, axes=F, breaks=1:(ncols+1)-0.5, col=cols,
ylab=ylab, xlab=xlab, ...)
abline(h=1:(ncols-1) + 0.5)
}