##============================================================================== ## Attaches a property to a 1D grid ##============================================================================== setup.prop.1D <- function(func = NULL, value = NULL, xy = NULL, interpolate = "spline", grid, ...) { ## check input gn <- names(grid) if (! "x.up" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains x.up") if (! "x.down" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains x.down") if (! "x.mid" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains x.mid") if (! "x.int" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains x.int") if (! "dx" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains dx") if (! "dx.aux" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains dx.aux") if (! "N" %in% gn) stop("error in setup.prop.1D: grid should be a list that contains N") if (is.null(xy) && is.null(value) && is.null(func)) stop("error in setup.prop.1D: function, value and xy cannot be NULL together") ## profile specification via function if (! is.null(func)) { y.int <- func(grid$x.int,...) ## KS ## if (length(y.int)==0) stop (" error in setup.prop.1D: 'func' should return a vector ") y.mid <- func(grid$x.mid,...) } if (! is.null(value)) { # profile specification via value y.int <- rep(value,times=length(grid$x.int)) y.mid <- rep(value,times=length(grid$x.mid)) } ## profile speficication via data series input if (! is.null(xy)) { if (! is.matrix(xy)) stop("error in setup.prop.1D: xy should be a 2-columned matrix or NULL") if (!(interpolate %in% c("linear","spline"))) stop("error in setup.prop.1D: 'interpolate' not properly specified, should be 'linear' or 'spline'") if (interpolate=="linear") { # check the range of input data-series (inr)) # this range should span the range of grid$x.int (outr) outr <- range(grid$x.int) # output range inr <- range(xy[,1]) # input range # extend the xy matrix if necessary if (outr[1]inr[2]) { xy <- rbind(xy,c(outr[2],xy[which.max(xy[,1]),2])) } # linear interpolation y.int <- approx(x=xy[,1],y=xy[,2],xout = grid$x.int)$y y.mid <- approx(x=xy[,1],y=xy[,2],xout = grid$x.mid)$y } else { # spline interpolation f <- splinefun(xy[,1],xy[,2]) y.int <- f(grid$x.int) y.mid <- f(grid$x.mid) } } Res <- list(mid = y.mid, int = y.int) class(Res) <- "prop.1D" return(Res) } ##============================================================================== ## S3 method: Plotting of a one-dimensional grid property ##============================================================================== plot.prop.1D <- function(x, grid, xyswap =FALSE, ...) { if (xyswap) plot(x$int, grid$x.int, ylim = rev(range(grid$x.int)), xlab="prop",ylab="x",...) else plot(grid$x.int,x$int, ylab="prop",xlab="x",...) }