Nothing
R/rf-plots.R
In RandomFields: Simulation and Analysis of Random Fields
Defines functions
contour.RFspatialGridDataFrame
errMsgNoPlotAvailable
RFplotSimulation1D
trafo_pointsdata
RFplotSimulation
PlotTitle
prepareplotRFsp
my.arrows
default.image.par
Documented in
contour.RFspatialGridDataFrame
RFplotSimulation
RFplotSimulation1D
## Authors
## Martin Schlather, schlather@math.uni-mannheim.de
##
##
## Copyright (C) 2012 -- 2014 Alexander Malinowski & Martin Schlather
## 2015 -- 2017 Martin Schlather
##
## This program is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License
## as published by the Free Software Foundation; either version 3
## of the License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
## use only via calls of 'eval(body())' from 'plotRFspatialGridDataFrame' or
## 'plotRFspatialPointsDataFrame'
default.image.par <- function(data.range, var.range, legend=TRUE) {
var.col <- try(colorspace::rainbow_hcl(12, c = 50, l = 70), silent=TRUE)
if (is(var.col, "try-error")) {
var.col <- try(RColorBrewer::brewer.pal(9, "Blues"), silent=TRUE)
if (is(var.col, "try-error")) {
if (RFoptions()$internal$warn_colour_palette) {
RFoptions(warn_colour_palette = FALSE)
message("Better install one of the packages 'colorspace' or 'RColorBrewer'. (This message appears only once per session.)")
}
data.col <- heat.colors(36)
var.col <- cm.colors(36)
} else {
data.col <- RColorBrewer::brewer.pal(9, "Reds")
}
} else {
data.col <- colorspace::heat_hcl(12, c. = c(80, 30), l = c(30, 90),
power = c(1/5, 1.5))
}
list(data=list(dot.name="col", default.col=data.col,
pch=16, cex=1, range=data.range),
var=list(dot.name="var.col", default.col=var.col,
pch=16, cex=1, range=var.range),
#mar = c(2,2,1,0),
#mar.leg = c(0, 2.2, 2, 0.2),
legend = legend,
lower.leg = if (legend) 0.85 else 1,
arrows = list(reduction = 1.5, nx.vectors = 20, leg.pos=c(1, 0.7)),
text.col="blue"
)
}
my.arrows <- function(xy, z, r, thinning, col, nrow) {
half <- as.integer(thinning / 2)
thinned <- c(rep(FALSE, half), TRUE, rep(FALSE, thinning - half))
if (!missing(nrow) && !is.null(nrow)) {
thinned <- as.vector(outer(rep(thinned, length = nrow),
rep(thinned, length = nrow(xy) / nrow), "&"))
}
arrows(x0=xy[thinned, 1] - r/2*z[thinned,1],
y0=xy[thinned, 2] - r/2*z[thinned,2],
x1=xy[thinned, 1] + r/2*z[thinned,1],
y1=xy[thinned, 2] + r/2*z[thinned,2], length=0.03, col=col)
}
prepareplotRFsp <- function(x, vdim, select, plot.var,
data.range, var.range,
MARGIN, n,
n.slices, plot.legend, zlim,
...) {
if (vdim == 1 && !identical(select, vdim))
stop("the given 'select.variables' do not match the data")
timespacedim <-
if (is(x, "RFspatialGridDataFrame")) length(x@grid@cellsize)
else ncol(x@coords)
if (!(length(MARGIN)==2)) stop("MARGIN must have length 2")
if (!all(MARGIN %in% 1:timespacedim)) stop("chosen MARGINS are out of bounds")
if (!missing(zlim)){
if (is.character(zlim)) stopifnot(zlim=="joint")
mychk <- function(zlim) stopifnot((is.null(dim(zlim)) && length(zlim)==2) ||
(is.matrix(zlim) && nrow(zlim)==2))
if (is.numeric(zlim)) mychk(zlim)
if (is.list(zlim)) {
stopifnot(names(zlim) %in% c("data", "var"))
lapply(zlim, mychk)
}
}
coordunits=x@.RFparams$coordunits
varunits=x@.RFparams$varunits;
graphics <- RFoptions()$graphics
image.par <- default.image.par(data.range, var.range, legend=plot.legend)
names.rep <- c(paste("realization", 1:(n-plot.var), sep=" "),
"kriging variance")
names.vdim <-
if (!is.null(names(x@data)) && all(nchar(names(x@data))>0)) {
if (is.list(select)) {
u <- unlist(lapply(strsplit(names(x@data), ".n"),
FUN=function(li) li[[1]]))
lapply(select, function(indices)
if (length(indices)==3) {
if (FALSE) warning("first component interpreted as scalar, the other two as vector")
paste(u[indices[1]], paste(u[indices[-1]], collapse="/"),
sep=" and ")
} else if (length(indices)>3) {
stop("currently, only two-dimensional vectors can be plotted")
} else paste(u[indices], collapse="/"))
} else unlist(lapply(strsplit(names(x@data)[unlist(select)], ".n"),
FUN=function(li) li[[1]]))
} else {
paste("variable", select)
}
names.coords <-
if (.hasSlot(x, "coords"))
dimnames(x@coords)[[2]]
else
names(x@grid@cellcentre.offset)
dots <- mergeWithGlobal(list(...))
names.graphics <- names(graphics)
for (i in 1:length(graphics)) {
dots[[names.graphics[i]]] <- NULL
}
dotnames <- names(dots)
if (bgInDots <- "bg" %in% dotnames) {
bgdots <- dots$bg
dots$bg <- NULL
}
lab <- xylabs(names.coords[MARGIN[1]], names.coords[MARGIN[2]],
units=coordunits )
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
if (!("pch" %in% dotnames)) dots$pch=image.par$data$pch
if (!("cex" %in% dotnames)) dots$cex=image.par$data$cex
## colours, legend
for (i in c("data", "var")) {
if (i=="var" && !plot.var) next
if (is.null(colour <- dots[[ image.par[[i]]$dot.name ]]))
colour <- image.par[[i]]$default.col
image.par[[i]]$col <- if (is.list(colour)) colour else list(colour)
dots[[ image.par[[i]]$dot.name ]] <- NULL
lencol <- length(colour)
image.par[[i]]$range <-
apply(image.par[[i]]$range, 2, function(x) {
if (is.logical(all.equal(x[1], x[2])))
warning("range of data is a single value")
stopifnot(all(is.finite(x)))
r <- range(outer(x, 1 + 0.05 * c(-1,1), "*"))
if (identical(r[1], r[2])) r[2] <- r[2]+1
return(r)
})
if (!missing(zlim)) {
idx <- unlist(lapply(as.list(select),
FUN=function(x) if (length(x) == 2) NA else x[1]))
idx <- idx[!is.na(idx)]
if (is.character(zlim) && zlim=="joint") {
image.par[[i]]$range[,idx] <- range(image.par[[i]]$range[,idx])
} else {
zz <- if (is.list(zlim)) zlim[[i]] else zlim
if (!is.null(zz))
image.par[[i]]$range[,idx] <- matrix(zz, nrow=2, ncol=length(idx))
}
}
image.par[[i]]$z.legend <-
as.matrix(apply(image.par[[i]]$range, 2,
function(x) seq(x[1], x[2], length=lencol)))
# if (ncol(image.par[[i]]$z.legend) == 1)
## image.par[[i]]$z.legend <- t(image.par[[i]]$z.legend)
image.par[[i]]$breaks <-
as.matrix(apply(image.par[[i]]$range, 2,
function(x) seq(x[1]-abs((x[2] - x[1])*1e-3),
x[2]+abs((x[2]-x[1])*1e-3), len=lencol+1)
))
}
### Splitting & Legend Plotting
len.sel <- length(select)
if (vdim>1) # note: one of n and n.slices is always equal to 1
split.main <- c(n * n.slices, len.sel)
else {
if (n * n.slices > 1)
split.main <- c(ceiling(n * n.slices/2), 2) else {
split.main <- c(1,1)
}
}
ArrangeDevice(graphics, figs=split.main) ## NIE par() o.ae. vor ArrangeDevice !!!!
par(cex=dots$cex) ## NIE par() o.ae. vor ArrangeDevice !!!!
if (bgInDots) par(bgdots)
xlab.given <- 1 - as.integer("xlab" %in% dotnames && (is.null(dots$xlab) ||
dots$xlab==""))
mar <- c(1,1,0,0)
image.par$data$mar.leg <- mar #+ c(0,0,2,0)
image.par$var$mar.leg <- mar + c(0,0,0,0)
oma.top <- 2*plot.legend + if (is.null(dots$main)) 0 else 2# + xlab.given
oma.left <- 2 * (1 + xlab.given)
oma.bottom <- oma.left + 0*(plot.legend && plot.var)
oma <- c(oma.bottom, oma.left, oma.top, xlab.given) + 0.2
#} else {
# mar <- c(rep(2 * (1 + xlab.given), 2), 0, 0)
# image.par$mar.leg <- c(1, mar[2], 2, 0)
# oma <- rep(0.2, 4) + (!is.null(dots$main)) * c(0,0,2,0)
#}
figs <- c(len.sel, prod(split.main) / len.sel)
legends <- scr <- scr.main <- scr.legends <- scr.leg <- NULL
if (graphics$split_screen) {
SCR <- scr <- split.screen(rbind(
c(0,1, 0,
if (plot.var) 1-2*(1-image.par$lower.leg) else image.par$lower.leg),
if (plot.legend) c(0, 1, image.par$lower.leg, 1),
if (plot.var && plot.legend) c(0,1,1-2*(1-image.par$lower.leg),
image.par$lower.leg)
))
scr.main <- matrix(nrow = figs[2],
split.screen(split.main, scr[1]),
byrow=TRUE) # statt nr=split.main[1]
scr.legends <- integer(0)
} else {
if (any(split.main != 1)) {
par(mfcol=split.main)
}
}
if (plot.legend) {
legends <- list(do = if (is.list(select)) sapply(select, length) != 2
else rep(TRUE, len.sel), units=coordunits)
for (i in c("data", if (plot.var) "var")) {
if (graphics$split_screen) {
SCR <- SCR[-1]
screen(SCR[1])
scr.leg <- split.screen(figs=c(1, len.sel))
scr.legends <- c(scr.legends, scr.leg)
for (jx in 1:length(scr.leg)) {
screen(scr.leg[jx])
par(oma=oma, mar=image.par[[i]]$mar.leg)
}
}
col <- image.par[[i]]$col
col <- sapply(1:len.sel, function(jx) col[[1+(jx-1) %% length(col)]],
simplify=FALSE)
if (!is.list(select) || length(select[[jx]]) != 2) {
if (any(sapply(col, length) <= 1))
stop("number of colours is one -- please choose an appropriate colour palette. Maybe 'RFpar(col=NULL)' will help.")
}
legends[[i]] <- list(scr=scr.leg, col = col,
z.legend = image.par[[i]]$z.legend)
}
}
return(c(image.par,
dots=list(dots),
list(legends = legends,
names.coords = names.coords, names.rep = names.rep,
names.vdim = names.vdim,
mar=mar, oma=oma,
scr.main=scr.main, scr.legends=scr.legends, scr = scr,
split.main=split.main, #figs=figs,
grPrintlevel = graphics$grPrintlevel)))
}
PlotTitle <- function(x, main) {
p <- x@.RFparams
# if (!is.null(p$krige.method)) main <- paste(p$krige.method, "\n", main)
par(mar=rep(0, 4), new=TRUE)
plot(Inf, Inf, xlim=c(0,1), ylim=c(0,1), axes=FALSE)
text(0, 0.5, labels=main, adj=1, xpd=NA, col="blue", cex=0.8) # links davon
}
RFplotSimulation <- function(x, y,
MARGIN =c(1,2),# which dimensions are to be plotted
MARGIN.slices =NULL,
## in which dimension a sequence of slices
## is to be plotted
n.slices = if (is.null(MARGIN.slices)) 1 else 10,
nmax=6, # max number of repetitins plotted
plot.variance = !is.null(x@.RFparams$has.variance)
&& x@.RFparams$has.variance,
select.variables, #1:vdim,
zlim, # default: missing,
legend = TRUE,
MARGIN.movie = NULL,
file=NULL, speed=0.3,
height.pixel=300, width.pixel=height.pixel,
..., plotmethod="image") {
if (is(x, "RFdataFrame"))
return(RFplotSimulation1D(x=x, y=y, nmax=nmax,
plot.variance=plot.variance, legend=legend, ...))
if (legend && plotmethod == "contour")
stop("no legend available for 'contour'")
## nmax, n.slices, plot.variance, select.variables, legend
graphics <- RFoptions()$graphics
x.grid <- is(x, "RFspatialGridDataFrame")
do.slices <- !is.null(MARGIN.slices)
do.movie <- !is.null(MARGIN.movie)
if (length(MARGIN.slices) > 1) stop("MARGIN.slices must be a scalar.")
if (length(MARGIN.movie) > 1) stop("MARGIN.movie must be a scalar.")
if (!x.grid) {
if (is(x, "RFspatialPointsDataFrame")) {
if (do.slices || n.slices[length(n.slices)] != 1)
stop("'MARGIN.slices' must be 'NULL' and 'n.slices' must be 1.")
} else {
stop("method only for objects of class 'RFspatialPointsDataFrame' and 'RFspatialGridDataFrame'")
}
}
NEWMARGIN <- MARGIN
has.variance <-
!is.null(x@.RFparams$has.variance) && x@.RFparams$has.variance
if (!has.variance) plot.variance <- FALSE
if (x.grid) {
conventional <- RFspDataFrame2conventional(x)
x.grid.vectors <-
GridTopology2gridVectors(cbind(conventional$x,conventional$T))
## array with dims (space-time-dims, vdim, n) AND drop=FALSE!!
timespacedim <- genuine.timespacedim <- length(x.grid.vectors)
if (timespacedim!=length(x@grid@cellsize))
stop("sollte nicht auftauchen: programming error in plotRFspatialGridDataFrame, timespacedim wrong ... (AM)")
if (do.slices){
if (!(MARGIN.slices <= timespacedim))
stop("chosen MARGIN.slices out of bounds")
if (MARGIN.slices %in% MARGIN)
stop("MARGIN.slices must be different from MARGIN")
}
if (length(n.slices)!=1 && length(n.slices)!=3)
stop("n.slices must be an integer of length 1 or 3")
data.arr <- RFspDataFrame2dataArray(x)
vdim <- dim(data.arr)[timespacedim+1]
n.orig <- dim(data.arr)[timespacedim+2] ## including the kriging variance as one repet
n.ohne.var <- n.orig - has.variance
n <- min(n.ohne.var, nmax) + plot.variance
## want to have at least 3 space-time dims, if only 2,
## generate artificial dim
dim_data <- dim(data.arr) # new dims
if (timespacedim <= 3){
if (timespacedim == 3)
dim(data.arr) <- c(dim_data[1:3], 1, dim_data[4:5])
else if (timespacedim==2)
dim(data.arr) <- c(dim_data[1:2], 1, 1, dim_data[3:4])
else stop("dimension too small: dim=", timespacedim)
timespacedim <- 4
}
if (!all(MARGIN %in% 1:(length(dim_data) - 2))) stop("MARGIN out of range.")
if (any(MARGIN.slices %in% MARGIN.movie))
stop("MARGIN.slices and MARGIN.movie are not disjoint.")
if (length(MARGIN.slices) < 1)
MARGIN.slices <-
(1:(max(MARGIN, MARGIN.movie) + 1))[-c(MARGIN, MARGIN.movie)][1]
if (length(MARGIN.movie) < 1)
MARGIN.movie <-
(1:(max(MARGIN, MARGIN.slices) + 1))[-c(MARGIN, MARGIN.slices)][1]
dim_data <- dim(data.arr)
vdimrep <- dim_data[(-1:0) + length(dim_data)]
if (!all(c(MARGIN.movie, MARGIN.slices) %in%
1:(length(dim_data) - 2))) stop("MARGINs out of range.")
xx <- x.grid.vectors[[MARGIN[1]]]
xy <- x.grid.vectors[[MARGIN[2]]]
## reduce the data array by taking a section with respect
## to the dimensions not covered by MARGIN*
mar.vec <- c(MARGIN, MARGIN.slices, MARGIN.movie)
ind <- as.list(rep(1, length(dim_data) - 2))
ind[mar.vec] <- TRUE
data.arr <- do.call("[", c(list(data.arr), ind, TRUE, TRUE, drop=FALSE))
dim(data.arr) <- c(dim_data[sort(mar.vec)], vdimrep)
## re-oredered dimensions such that MARGIN and MARGIN.slices
## and MARGIN.movie are the first 4 dimensions
perm.tmp <- c(mar.vec, (-1:0) + length(dim_data))
data.arr <- aperm(data.arr, perm.tmp)
dim_data <- dim(data.arr)
NEWMARGIN <- 1:2
MARGIN.slices <- 3
MARGIN.movie <- 4
if (do.slices) {
if (n != 1) {
n <- 1
message("only first realization is shown")
}
if (plot.variance){
plot.variance <- FALSE
message("plot.variance was set to FALSE")
}
mar.len <- dim_data[MARGIN.slices]
if (n.slices[length(n.slices)] > mar.len)
n.slices[length(n.slices)] <- mar.len
slices.ind <-
if (length(n.slices) == 1) seq(1, mar.len, length=n.slices)
else seq(n.slices[1], n.slices[2], length=n.slices[3])
slices.ind <- unique(round(slices.ind))
slices.ind <- slices.ind[slices.ind >= 1 & slices.ind <= mar.len]
## which indices in the slices dimension are taken
} else {
slices.ind <- 1
## the first dimension which is not in MARGIN
}
n.slices <- length(slices.ind)
## ersten n.orig-1 sind wiederholungen, die letzte 'Spalte'
## ist die Varianz falls existent
data.idx <- 1 : (n.ohne.var*vdim)
all.i <- as.matrix(expand.grid(1:n.slices, 1:n)[2:1]) ## i, ii
coords <- as.matrix(expand.grid(xx, xy))
m.range <- if (do.movie) 1:dim_data[MARGIN.movie] else 1
} else { ## not grid
vdim <- x@.RFparams$vdim
n <- min(x@.RFparams$n, nmax) + plot.variance
nc <- ncol(x@data)
if (nc < n*vdim)
if (n==1) vdim <- nc else if (vdim==1) n <- nc else {
stop("ncol(x@data) does not match 'x@.RFparams'; change 'x@.RFparams'")
}
data.idx <- 1:(x@.RFparams$n*vdim)
all.i <- cbind(1:n, 1)
genuine.timespacedim <- ncol(x@coords)
coords <- x@coords[, MARGIN]
m.range <- 1
}
if (!(missing.y <- missing(y))) {
if (do.slices)
stop("'y' and 'MARGIN.slices' may not be given at the same time")
#
## eigentlich hier UnifyData
if (is(y, 'RFspatialGridDataFrame')) {
y.coords <- as(y, "RFspatialPointsDataFrame")@coords
y.data <- y@data
} else if (is(y, "matrix") || is(y, "data.frame")) {
dc <- data.columns(data=y, xdim = dimensions(x), force=TRUE)
y.coords <- y[, dc$is.x, drop=FALSE]
y.data <- y[, dc$is.data, drop=FALSE]
# Print(dc, y, x, dimensions(x), dc, y.coords, y.data)
} else {
y.coords <- y@coords
y.data <- y@data
}
}
data.range <-
apply(as.matrix(1:vdim), 1, # statt data.idx # pro vdim eine legend
function(z) {
## Print(z, missing.y)
d <- if (missing.y) x@data[z + vdim * 0:(n-plot.variance-1)]
else {
idx <- z + vdim * 0:(n-plot.variance-1)
## Print(idx,z,vdim,n,plot.variance,idx[idx <= ncol(y.data)],y.data)
c(#x@data[idx],
y.data[, idx[idx <= ncol(y.data)]])
}
## Print(d, range(d, na.rm=TRUE))
range(d,na.rm=TRUE)
})
## Print(data.range)
var.range <- if (plot.variance) sapply(x@data[-data.idx],
range, na.rm=TRUE) else NULL
if (missing(select.variables)) select.variables <- 1:vdim
image.par <- prepareplotRFsp(x=x, vdim=vdim, select=select.variables,
data.range = data.range, var.range=var.range,
plot.var=plot.variance, MARGIN=NEWMARGIN,
n=n, n.slices=n.slices, plot.legend=legend,
zlim=zlim,
...)
image.par$names.vdim <-
add.units(image.par$names.vdim, x@.RFparams$varunits)
legends <- image.par$legends
if (x.grid) {
nx.vectors <- min(length(xx), image.par$arrow$nx.vectors)
thinning <- as.integer( (length(xx)-1) / nx.vectors)
} else {
nx.vectors <- min(nrow(coords), image.par$arrow$nx.vectors^2)
thinning <- as.integer( (nrow(coords)-1) / nx.vectors^2)
}
## split the left part according to 'split.main' for different vdims and
## repetitions
current <- dev.cur()
if (do.avi <- as.integer(do.movie && length(file) > 0)) {
ans <- system("mencoder")
if (ans != 0 && ans != 1) stop("'mencoder' needs to be installed first.")
digits <- 1 + ceiling(log(max(m.range)) / log(10))
fn <- character(max(m.range))
}
if (!graphics$split_screen) {
if (graphics$always_open_device) par(oma=image.par$oma)
else if (all(par()$oma == 0) &&
(any(par()$mfcol != 1) || any(par()$mfrow != 1)))
stop("par()$oma has not been set; 'oma=rep(2,4)' is a good choice.")
}
for (m in m.range) {
if (do.avi) {
fn[m] <- paste(file, "__", formatC(m, width=digits, flag="0",
format="d"), ".png", sep="")
if (file.exists(fn[m])) stop(fn[m], "already exists.");
png(height=height.pixel, width=width.pixel, filename=fn[m])
filedev <- dev.cur()
par(mfcol=image.par$split.main, mar=c(.2, .2, .2, .2))
dev.set(current)
} else filedev <- dev.cur()
for (jx in 1:length(select.variables)) {
j <- if (is.list(select.variables)) select.variables[[jx]]
else select.variables[jx]
for (ix in 1:nrow(all.i)) {
i <- all.i[ix, ]
dots <- dots.with.main.lab <- image.par$dots
main <- dots$main
dots$main <- NULL
lab <- xylabs("", "", units=x@.RFparams$coordunits)
dots$xlab <- lab$x
dots$ylab <- lab$y
if (do.plot.var <- (plot.variance && i[1]==n)){
k <- if (x.grid) n.orig else x@.RFparams$n + 1;
dv <- "var"
} else {
k <- i[1]
dv <- "data"
}
if (graphics$split_screen) {
screen(image.par$scr.main[ix, jx])
par(oma=image.par$oma)
}
par(mar=image.par$mar)
len.col <- length(image.par[[dv]]$col)
col <- image.par[[dv]]$col[[ 1 + (j[1]-1) %% len.col]]
breaks <- image.par[[dv]]$breaks[, j[1]]
genuine.image <- (length(j) == 1 || length(j)==3)
if (x.grid) {
dots$type <- NULL
dots$col <- if (genuine.image) col else par()$bg
for (devices in 0:do.avi) {
args <- c(dots, list(x=xx, y=xy, z=data.arr[,,i[2], m, j[1], k],
zlim = image.par[[dv]]$range[, j[1]],
axes = plotmethod == "persp"))
plot.return <- do.call(plotmethod, args=args)
dev.set(filedev)
}
dev.set(current)
} else {
idx <- if (n==1) j else if (vdim==1) k else (k-1)*vdim+j
dots$col <- if (genuine.image)
col[ cut(x@data[,idx[1]], breaks=breaks) ] else par()$bg
for (devices in 0:do.avi) {
do.call(graphics::plot,
args=c(dots, list(x=coords[, 1], y=coords[, 2],
axes=FALSE)))
box()
dev.set(filedev)
}
dev.set(current)
}
if (image.par$legend && ix == 1 && legends$do[jx]) {
leg <- legends[[dv]]$z.legend[, j[1]]
if (graphics$split_screen) {
screen(legends[[dv]]$scr[jx])
lab <- xylabs("", "", units=legends$units)
image(x=leg, y=c(0,1),
z=matrix(ncol=2, rep(leg, 2)),
axes=FALSE, xlab=lab$x, ylab=lab$y,
col=legends[[dv]]$col[[jx]]
)
axis(3, mgp=if (do.plot.var) c(3,0,0),
hadj=if (do.plot.var) -0.5 else NA)#1 + 2 * (dv =="data"))
box()
screen(image.par$scr.main[ix, jx])
} else { ## not split.screen
my.legend(min(xx), max(xy), image.par[[dv]]$range[, j[1]],
col=legends[[dv]]$col[[jx]], bg="white")
}
}
for (devices in 0:do.avi) {
if (n.slices > 1)
legend("bottomright", bty="n",
legend=paste(image.par$names.coords[MARGIN.slices], "=",
x.grid.vectors[[MARGIN.slices]][slices.ind[i[2]]]))
if (do.plot.arrows <- length(j) >= 2 && !do.plot.var) {
jj <- if (length(j) == 3) j[-1] else jj <- j
rx <- range(coords[, 1])
ry <- range(coords[, 2])
col.arrow <- if (length(image.par[["data"]]$col) >= jj[1] &&
length(image.par[["data"]]$col[[jj[1]]]) == 1)
image.par[["data"]]$col[[jj[1]]] else "black"
if (ix == 1) { ## to do: document in a paper?
factor <- image.par$arrow$reduction *
sqrt(diff(rx) * diff(ry) / max(x@data[jj[1]]^2 +
x@data[jj[2]]^2)) / nx.vectors
}
my.arrows(coords, x@data[jj], r = factor, thinning = thinning,
col = col.arrow,
nrow = if (x.grid) length(xx))
}
if (!do.plot.var && !missing.y && (length(j)==1 || (length(j)==3))) {
idx <- if (n==1) j else if (vdim==1) i[1] else (i[1]-1)*vdim+j
if (ncol(y.data) < idx) idx <- 1
if (plotmethod == "persp") {
# theta = 30, phi = 30, expand = 0.5,
xy <- trans3d(y.coords[, MARGIN[1]], y.coords[, MARGIN[2]],
data[ , idx], pmat=plot.return)
points(xy, pch=16, col="black")
} else {
col2 <- col[ cut(y.data[ , idx], breaks=breaks) ]
dots2 <- dots
dots2[c("type", "pch", "lty", "col", "bg", "cex", "lwd")] <- NULL
addpoints <- function(pch, col, cex) {
do.call(graphics::plot.xy,
args=c(dots2,
list(xy=xy.coords(y.coords[, MARGIN[1]],
y.coords[, MARGIN[2]]),
type="p", pch=pch, lty=1, col=col, bg=NA,
cex=cex, lwd=1)))
}
if (plotmethod=="image") addpoints(15, "darkgray", dots$cex*2)
addpoints(dots$pch, col2, dots$cex) ## causes error in
} # not persp
} # !do.plot.var
if (ix==1 ||
((image.par$split.main[1] != nrow(all.i)) &&
(ix <= image.par$split.main[2]))) {
## nrow(all.i) || #!image.par$always.close ||
axis(1, outer=TRUE)#image.par$always.close
}
if (jx==1 &&
((image.par$split.main[2] == length(select.variables)) ||
((ix-1) %% image.par$split.main[2] == 0))) # !image.par$always.close ||
axis(2, outer=TRUE)#image.par$always.close)
if (all(i==1) && (image.par$grPrintlevel > 1 || vdim>1)) {
mtext(text = image.par$names.vdim[jx], # names(x)[j[1]]
side=3, line=-1,
col = image.par$text.col, cex=dots$cex)
}
if (n>1 && jx==1){
mtext(text = image.par$names.rep[ix], side=3, line=-2, cex=dots$cex)
}
dev.set(filedev)
}
dev.set(current)
if (image.par$legend && ix == 1) {
if (do.plot.arrows) {
## do not merge with ix==1 above !!
## reason: screen is changed here and going back
## is not a good idea
len <- max(pretty(diff(rx) / image.par$arrows$nx.vectors/2 /factor))
if (graphics$split_screen) {
x.arrow <- cbind(mean(rx),
image.par$arrows$leg.pos[1+genuine.image])
screen(image.par$scr.legends[jx])
do.call(graphics::plot, args=c(dots, list(x=Inf, y=Inf,
xlim=rx, ylim=c(0,1), axes=FALSE)))
colArrow <- col.arrow
} else {
dy <- diff(range(xy))
xl <- max(xx) - 0.05 * diff(range(xx))
yl <- max(xy) - 0.02 * dy
points(rep(xl, 2), rep(yl-0.01 * dy, 2), pch=c(16, 1), cex=7,
col=c("white", "black"))
x.arrow <- cbind(xl, yl)
colArrow <- "red"
}
my.arrows(x.arrow, cbind(len, 0), r = factor,
thinning=0, col=colArrow)
text(x.arrow, pos=1, labels = len, col=colArrow)
}
}
} # ix (rows)
} # jx
dots.with.main.lab$type <- NULL # woher kommt dieses type??
dots.with.main.lab$zlab <- NULL
## falls nicht auf NULL gesetzt gibt es einen Fehler. Warum?
do.call(graphics::title,
args=list(main=dots.with.main.lab$main,
outer=TRUE, line=image.par$oma[3]-1.5))
dots.with.main.lab$main <- NULL
do.call(graphics::title,
args=c(dots.with.main.lab, list(outer=TRUE, line=NA)))
if (image.par$grPrintlevel > 0) {
if (graphics$split_screen) {
screen(image.par$scr[1 + image.par$legend], new=FALSE)
PlotTitle(x, if (is.null(main)) "" else main)
} #else if (!is.null(main)) title(main=main)
}
if (do.avi) {
dev.off(filedev)
dev.set(current)
}
} # m in m.range
if (do.avi) {
txt <- paste("mencoder -mf fps=30 -ffourcc DX50 -ovc lavc ",
" -speed ", speed,
" -lavcopts vcodec=mpeg4:vbitrate=9800:aspect=4/3:vhq:keyint=15",
" -vf scale=720:576 -o ", file, ".avi mf://",
file, "__*.png", sep="")
system(txt)
file.remove(fn)
}
scr <- image.par[c("scr.main", "scr.legends", "scr", "split.main")]
if (graphics$split_screen && graphics$close_screen){
close.screen(unlist(scr))
scr <- NULL
}
return(invisible(scr))
}
trafo_pointsdata <- function(x, dim) {
if (isgrid <- is(x, "RFgridDataFrame")) {
x <- grid2pts1D(x) ## x <- as(x, "RFpointsDataFrame") # funktionierte nicht
} else if ((is(x, "matrix") || is(x, "data.frame")) && !missing(dim)) {
dc <- data.columns(data=x, xdim = dim, force=TRUE)
x <- list(coords=x[, dc$is.x, drop=FALSE], data=x[, dc$is.data, drop=FALSE])
} else {
if (!is(x, "RFpointsDataFrame"))
stop("method only for objects of class 'RFpointsDataFrame' and 'RFgridDataFrame'")
}
dummy <- dimnames(x@coords)[[2]][1]
lab <- xylabs(if (is.null(dummy)) "" else dummy, "",
units=x@.RFparams$coordunits)
labdata <- names(x@data)
colname <- colnames(x@data)
if (isgrid) {
return(list(coords=as.vector(x@coords),
data=as.matrix(x@data),
RFparams=x@.RFparams,
lab=lab, labdata=labdata, colnames=colname))
} else {
ord <- order(x@coords)
return(list(coords=x@coords[ord, ],
data=as.matrix(x@data)[ord, , drop=FALSE],
RFparams=x@.RFparams,
lab=lab, labdata=labdata, colnames=colname))
}
}
RFplotSimulation1D <- function(x, y, nmax=6,
plot.variance=!is.null(x@.RFparams$has.variance) &&
x@.RFparams$has.variance,
legend=TRUE, ...) {
## grid : sorted = TRUE
## points : sorted = FALSE
stopifnot(!missing(x))
x <- trafo_pointsdata(x)
nc <- ncol(x$data)
if (!missing(y)) {
y <- trafo_pointsdata(y, dimensions(dim))
y$data <- rep(y$data, length.out=nrow(y$data) * nc)
dim(y$data) <- c(length(y$coords), nc)
}
has.variance <- !is.null(x$RFparams$has.variance) && x$RFparams$has.variance
if (!has.variance) plot.variance <- FALSE
n <- min(x$RFparams$n, nmax) + plot.variance
vdim <- x$RFparams$vdim
if (nc < n*vdim) {
if (n==1) vdim <- nc else if (vdim==1) n <- nc else {
stop("ncol(x@data) does not match 'x@.RFparams'; change 'x@.RFparams'")
}
}
graphics <- RFoptions()$graphics
ArrangeDevice(graphics, c(1, n)) ## NIE par vor ArrangeDevice !!!!
dots <- mergeWithGlobal(list(...))
dotnames <- names(dots)
if ("bg" %in% dotnames) {
par(bg=dots$bg)
dots$bg <- NULL
}
if (!("xlab" %in% dotnames)) dots$xlab <- x$lab$x
if (!("type" %in% dotnames)) dots$type <- "l"
make.small.mar <- ("xlab" %in% dotnames &&
is.null(dots$xlab) && is.null(dots$ylab))
## variable names
if (!is.null(x$labdata) && all(nchar(x$labdata)>0))
names.vdim <- unlist(lapply(strsplit(x$labdata[1:vdim], ".n"),
FUN=function(li) li[[1]]))
else {
names.vdim <- paste("variable", 1:vdim)
x$labdata <- names.vdim
}
if (n>1){
ylab.vec <- c(paste("realization ", 1:(n-plot.variance), sep=""),
if (plot.variance) "kriging variance")
} else {
ylab.vec <- if (vdim==1) x$colnames else ""
}
if ("ylab" %in% dotnames) {
if (!is.null(dots$ylab))
ylab.vec[1:length(ylab.vec)] <- dots$ylab
dots$ylab <- NULL
}
col <- 1:vdim
if ("col" %in% dotnames) {
if (!is.null(dots$col))
col[1:length(col)] <- dots$col
dots$col <- NULL
}
if (graphics$split_screen) scr <- split.screen(c(n,1))
else {
scr <- NULL
par(mfrow=c(n, 1), mar=c(1, 1, 0.1, 0.1))
}
for (i in 1:n){
if (graphics$split_screen) screen(i)
if (make.small.mar) {
if (graphics$split_screen) par(oma=c(3,0,1,1)+.1, mar=c(0,3,0,0))
else par(oma=rep(0,4), mar=c(3, 3, 1, 1), cex=0.6)
} else par(oma=c(4,0,1,1)+.1, mar=c(0,4,0,0))
ylab <- ylab.vec[i]
if (tmp.idx <- (plot.variance && i==n)){
i <- x$RFparams$n + plot.variance
}
do.call(graphics::matplot,
args=c(dots,
list(
x=x$coords, y=x$data[ , vdim*(i-1)+(1:vdim)],
xaxt="n", yaxt="n", ylab=ylab, col=col))
)
if (!missing(y)) {
points(x=y$coords, y=y$data[ , vdim*(i-1)+(1:vdim)], pch=22, col="red")
}
axis(2)
if (tmp.idx) i <- n
if (i==1) {
if ( (vdim > 1) && legend) {
legend("topright", col=col, lty=1, legend = c(names.vdim))
}
} else if (i==n) {
axis(1, outer=n>1)
title(xlab=dots$xlab, outer=TRUE)
} else axis(1, labels=FALSE)
}
if (graphics$close_screen) {
close.screen(scr)
scr <- NULL
}
return(invisible(scr))
}
errMsgNoPlotAvailable <- function(x, y)
warning(paste("no plot method available for signature c(",
class(x), ",", class(y), ")"))
setMethod(f="plot", signature(x="RFgridDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation1D(x, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation1D(x, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation(x, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation(x, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="RFgridDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="RFpointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="RFgridDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="RFpointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot",
signature(x="RFspatialGridDataFrame", y="RFspatialGridDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot",
signature(x="RFspatialGridDataFrame", y="RFspatialPointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame",
y="RFspatialGridDataFrame"),
definition=function(x, y, ...) {
errMsgNoPlotAvailable(x, y)
return(invisible(NULL))
})
setMethod(f="plot",
signature(x="RFspatialPointsDataFrame", y="RFspatialPointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="persp",
signature(x="RFspatialGridDataFrame"),
definition=function(x, ..., zlab="")
RFplotSimulation(x, ..., zlab=zlab, plotmethod="persp"))
contour.RFspatialGridDataFrame <- function(x, ...)
RFplotSimulation(x, ..., plotmethod="contour")
Try the RandomFields package in your browser
Any scripts or data that you put into this service are public.
RandomFields documentation built on Jan. 19, 2022, 1:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions contour.RFspatialGridDataFrame errMsgNoPlotAvailable RFplotSimulation1D trafo_pointsdata RFplotSimulation PlotTitle prepareplotRFsp my.arrows default.image.par
Documented in contour.RFspatialGridDataFrame RFplotSimulation RFplotSimulation1D
## Authors
## Martin Schlather, schlather@math.uni-mannheim.de
##
##
## Copyright (C) 2012 -- 2014 Alexander Malinowski & Martin Schlather
## 2015 -- 2017 Martin Schlather
##
## This program is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License
## as published by the Free Software Foundation; either version 3
## of the License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
## use only via calls of 'eval(body())' from 'plotRFspatialGridDataFrame' or
## 'plotRFspatialPointsDataFrame'
default.image.par <- function(data.range, var.range, legend=TRUE) {
var.col <- try(colorspace::rainbow_hcl(12, c = 50, l = 70), silent=TRUE)
if (is(var.col, "try-error")) {
var.col <- try(RColorBrewer::brewer.pal(9, "Blues"), silent=TRUE)
if (is(var.col, "try-error")) {
if (RFoptions()$internal$warn_colour_palette) {
RFoptions(warn_colour_palette = FALSE)
message("Better install one of the packages 'colorspace' or 'RColorBrewer'. (This message appears only once per session.)")
}
data.col <- heat.colors(36)
var.col <- cm.colors(36)
} else {
data.col <- RColorBrewer::brewer.pal(9, "Reds")
}
} else {
data.col <- colorspace::heat_hcl(12, c. = c(80, 30), l = c(30, 90),
power = c(1/5, 1.5))
}
list(data=list(dot.name="col", default.col=data.col,
pch=16, cex=1, range=data.range),
var=list(dot.name="var.col", default.col=var.col,
pch=16, cex=1, range=var.range),
#mar = c(2,2,1,0),
#mar.leg = c(0, 2.2, 2, 0.2),
legend = legend,
lower.leg = if (legend) 0.85 else 1,
arrows = list(reduction = 1.5, nx.vectors = 20, leg.pos=c(1, 0.7)),
text.col="blue"
)
}
my.arrows <- function(xy, z, r, thinning, col, nrow) {
half <- as.integer(thinning / 2)
thinned <- c(rep(FALSE, half), TRUE, rep(FALSE, thinning - half))
if (!missing(nrow) && !is.null(nrow)) {
thinned <- as.vector(outer(rep(thinned, length = nrow),
rep(thinned, length = nrow(xy) / nrow), "&"))
}
arrows(x0=xy[thinned, 1] - r/2*z[thinned,1],
y0=xy[thinned, 2] - r/2*z[thinned,2],
x1=xy[thinned, 1] + r/2*z[thinned,1],
y1=xy[thinned, 2] + r/2*z[thinned,2], length=0.03, col=col)
}
prepareplotRFsp <- function(x, vdim, select, plot.var,
data.range, var.range,
MARGIN, n,
n.slices, plot.legend, zlim,
...) {
if (vdim == 1 && !identical(select, vdim))
stop("the given 'select.variables' do not match the data")
timespacedim <-
if (is(x, "RFspatialGridDataFrame")) length(x@grid@cellsize)
else ncol(x@coords)
if (!(length(MARGIN)==2)) stop("MARGIN must have length 2")
if (!all(MARGIN %in% 1:timespacedim)) stop("chosen MARGINS are out of bounds")
if (!missing(zlim)){
if (is.character(zlim)) stopifnot(zlim=="joint")
mychk <- function(zlim) stopifnot((is.null(dim(zlim)) && length(zlim)==2) ||
(is.matrix(zlim) && nrow(zlim)==2))
if (is.numeric(zlim)) mychk(zlim)
if (is.list(zlim)) {
stopifnot(names(zlim) %in% c("data", "var"))
lapply(zlim, mychk)
}
}
coordunits=x@.RFparams$coordunits
varunits=x@.RFparams$varunits;
graphics <- RFoptions()$graphics
image.par <- default.image.par(data.range, var.range, legend=plot.legend)
names.rep <- c(paste("realization", 1:(n-plot.var), sep=" "),
"kriging variance")
names.vdim <-
if (!is.null(names(x@data)) && all(nchar(names(x@data))>0)) {
if (is.list(select)) {
u <- unlist(lapply(strsplit(names(x@data), ".n"),
FUN=function(li) li[[1]]))
lapply(select, function(indices)
if (length(indices)==3) {
if (FALSE) warning("first component interpreted as scalar, the other two as vector")
paste(u[indices[1]], paste(u[indices[-1]], collapse="/"),
sep=" and ")
} else if (length(indices)>3) {
stop("currently, only two-dimensional vectors can be plotted")
} else paste(u[indices], collapse="/"))
} else unlist(lapply(strsplit(names(x@data)[unlist(select)], ".n"),
FUN=function(li) li[[1]]))
} else {
paste("variable", select)
}
names.coords <-
if (.hasSlot(x, "coords"))
dimnames(x@coords)[[2]]
else
names(x@grid@cellcentre.offset)
dots <- mergeWithGlobal(list(...))
names.graphics <- names(graphics)
for (i in 1:length(graphics)) {
dots[[names.graphics[i]]] <- NULL
}
dotnames <- names(dots)
if (bgInDots <- "bg" %in% dotnames) {
bgdots <- dots$bg
dots$bg <- NULL
}
lab <- xylabs(names.coords[MARGIN[1]], names.coords[MARGIN[2]],
units=coordunits )
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
if (!("pch" %in% dotnames)) dots$pch=image.par$data$pch
if (!("cex" %in% dotnames)) dots$cex=image.par$data$cex
## colours, legend
for (i in c("data", "var")) {
if (i=="var" && !plot.var) next
if (is.null(colour <- dots[[ image.par[[i]]$dot.name ]]))
colour <- image.par[[i]]$default.col
image.par[[i]]$col <- if (is.list(colour)) colour else list(colour)
dots[[ image.par[[i]]$dot.name ]] <- NULL
lencol <- length(colour)
image.par[[i]]$range <-
apply(image.par[[i]]$range, 2, function(x) {
if (is.logical(all.equal(x[1], x[2])))
warning("range of data is a single value")
stopifnot(all(is.finite(x)))
r <- range(outer(x, 1 + 0.05 * c(-1,1), "*"))
if (identical(r[1], r[2])) r[2] <- r[2]+1
return(r)
})
if (!missing(zlim)) {
idx <- unlist(lapply(as.list(select),
FUN=function(x) if (length(x) == 2) NA else x[1]))
idx <- idx[!is.na(idx)]
if (is.character(zlim) && zlim=="joint") {
image.par[[i]]$range[,idx] <- range(image.par[[i]]$range[,idx])
} else {
zz <- if (is.list(zlim)) zlim[[i]] else zlim
if (!is.null(zz))
image.par[[i]]$range[,idx] <- matrix(zz, nrow=2, ncol=length(idx))
}
}
image.par[[i]]$z.legend <-
as.matrix(apply(image.par[[i]]$range, 2,
function(x) seq(x[1], x[2], length=lencol)))
# if (ncol(image.par[[i]]$z.legend) == 1)
## image.par[[i]]$z.legend <- t(image.par[[i]]$z.legend)
image.par[[i]]$breaks <-
as.matrix(apply(image.par[[i]]$range, 2,
function(x) seq(x[1]-abs((x[2] - x[1])*1e-3),
x[2]+abs((x[2]-x[1])*1e-3), len=lencol+1)
))
}
### Splitting & Legend Plotting
len.sel <- length(select)
if (vdim>1) # note: one of n and n.slices is always equal to 1
split.main <- c(n * n.slices, len.sel)
else {
if (n * n.slices > 1)
split.main <- c(ceiling(n * n.slices/2), 2) else {
split.main <- c(1,1)
}
}
ArrangeDevice(graphics, figs=split.main) ## NIE par() o.ae. vor ArrangeDevice !!!!
par(cex=dots$cex) ## NIE par() o.ae. vor ArrangeDevice !!!!
if (bgInDots) par(bgdots)
xlab.given <- 1 - as.integer("xlab" %in% dotnames && (is.null(dots$xlab) ||
dots$xlab==""))
mar <- c(1,1,0,0)
image.par$data$mar.leg <- mar #+ c(0,0,2,0)
image.par$var$mar.leg <- mar + c(0,0,0,0)
oma.top <- 2*plot.legend + if (is.null(dots$main)) 0 else 2# + xlab.given
oma.left <- 2 * (1 + xlab.given)
oma.bottom <- oma.left + 0*(plot.legend && plot.var)
oma <- c(oma.bottom, oma.left, oma.top, xlab.given) + 0.2
#} else {
# mar <- c(rep(2 * (1 + xlab.given), 2), 0, 0)
# image.par$mar.leg <- c(1, mar[2], 2, 0)
# oma <- rep(0.2, 4) + (!is.null(dots$main)) * c(0,0,2,0)
#}
figs <- c(len.sel, prod(split.main) / len.sel)
legends <- scr <- scr.main <- scr.legends <- scr.leg <- NULL
if (graphics$split_screen) {
SCR <- scr <- split.screen(rbind(
c(0,1, 0,
if (plot.var) 1-2*(1-image.par$lower.leg) else image.par$lower.leg),
if (plot.legend) c(0, 1, image.par$lower.leg, 1),
if (plot.var && plot.legend) c(0,1,1-2*(1-image.par$lower.leg),
image.par$lower.leg)
))
scr.main <- matrix(nrow = figs[2],
split.screen(split.main, scr[1]),
byrow=TRUE) # statt nr=split.main[1]
scr.legends <- integer(0)
} else {
if (any(split.main != 1)) {
par(mfcol=split.main)
}
}
if (plot.legend) {
legends <- list(do = if (is.list(select)) sapply(select, length) != 2
else rep(TRUE, len.sel), units=coordunits)
for (i in c("data", if (plot.var) "var")) {
if (graphics$split_screen) {
SCR <- SCR[-1]
screen(SCR[1])
scr.leg <- split.screen(figs=c(1, len.sel))
scr.legends <- c(scr.legends, scr.leg)
for (jx in 1:length(scr.leg)) {
screen(scr.leg[jx])
par(oma=oma, mar=image.par[[i]]$mar.leg)
}
}
col <- image.par[[i]]$col
col <- sapply(1:len.sel, function(jx) col[[1+(jx-1) %% length(col)]],
simplify=FALSE)
if (!is.list(select) || length(select[[jx]]) != 2) {
if (any(sapply(col, length) <= 1))
stop("number of colours is one -- please choose an appropriate colour palette. Maybe 'RFpar(col=NULL)' will help.")
}
legends[[i]] <- list(scr=scr.leg, col = col,
z.legend = image.par[[i]]$z.legend)
}
}
return(c(image.par,
dots=list(dots),
list(legends = legends,
names.coords = names.coords, names.rep = names.rep,
names.vdim = names.vdim,
mar=mar, oma=oma,
scr.main=scr.main, scr.legends=scr.legends, scr = scr,
split.main=split.main, #figs=figs,
grPrintlevel = graphics$grPrintlevel)))
}
PlotTitle <- function(x, main) {
p <- x@.RFparams
# if (!is.null(p$krige.method)) main <- paste(p$krige.method, "\n", main)
par(mar=rep(0, 4), new=TRUE)
plot(Inf, Inf, xlim=c(0,1), ylim=c(0,1), axes=FALSE)
text(0, 0.5, labels=main, adj=1, xpd=NA, col="blue", cex=0.8) # links davon
}
RFplotSimulation <- function(x, y,
MARGIN =c(1,2),# which dimensions are to be plotted
MARGIN.slices =NULL,
## in which dimension a sequence of slices
## is to be plotted
n.slices = if (is.null(MARGIN.slices)) 1 else 10,
nmax=6, # max number of repetitins plotted
plot.variance = !is.null(x@.RFparams$has.variance)
&& x@.RFparams$has.variance,
select.variables, #1:vdim,
zlim, # default: missing,
legend = TRUE,
MARGIN.movie = NULL,
file=NULL, speed=0.3,
height.pixel=300, width.pixel=height.pixel,
..., plotmethod="image") {
if (is(x, "RFdataFrame"))
return(RFplotSimulation1D(x=x, y=y, nmax=nmax,
plot.variance=plot.variance, legend=legend, ...))
if (legend && plotmethod == "contour")
stop("no legend available for 'contour'")
## nmax, n.slices, plot.variance, select.variables, legend
graphics <- RFoptions()$graphics
x.grid <- is(x, "RFspatialGridDataFrame")
do.slices <- !is.null(MARGIN.slices)
do.movie <- !is.null(MARGIN.movie)
if (length(MARGIN.slices) > 1) stop("MARGIN.slices must be a scalar.")
if (length(MARGIN.movie) > 1) stop("MARGIN.movie must be a scalar.")
if (!x.grid) {
if (is(x, "RFspatialPointsDataFrame")) {
if (do.slices || n.slices[length(n.slices)] != 1)
stop("'MARGIN.slices' must be 'NULL' and 'n.slices' must be 1.")
} else {
stop("method only for objects of class 'RFspatialPointsDataFrame' and 'RFspatialGridDataFrame'")
}
}
NEWMARGIN <- MARGIN
has.variance <-
!is.null(x@.RFparams$has.variance) && x@.RFparams$has.variance
if (!has.variance) plot.variance <- FALSE
if (x.grid) {
conventional <- RFspDataFrame2conventional(x)
x.grid.vectors <-
GridTopology2gridVectors(cbind(conventional$x,conventional$T))
## array with dims (space-time-dims, vdim, n) AND drop=FALSE!!
timespacedim <- genuine.timespacedim <- length(x.grid.vectors)
if (timespacedim!=length(x@grid@cellsize))
stop("sollte nicht auftauchen: programming error in plotRFspatialGridDataFrame, timespacedim wrong ... (AM)")
if (do.slices){
if (!(MARGIN.slices <= timespacedim))
stop("chosen MARGIN.slices out of bounds")
if (MARGIN.slices %in% MARGIN)
stop("MARGIN.slices must be different from MARGIN")
}
if (length(n.slices)!=1 && length(n.slices)!=3)
stop("n.slices must be an integer of length 1 or 3")
data.arr <- RFspDataFrame2dataArray(x)
vdim <- dim(data.arr)[timespacedim+1]
n.orig <- dim(data.arr)[timespacedim+2] ## including the kriging variance as one repet
n.ohne.var <- n.orig - has.variance
n <- min(n.ohne.var, nmax) + plot.variance
## want to have at least 3 space-time dims, if only 2,
## generate artificial dim
dim_data <- dim(data.arr) # new dims
if (timespacedim <= 3){
if (timespacedim == 3)
dim(data.arr) <- c(dim_data[1:3], 1, dim_data[4:5])
else if (timespacedim==2)
dim(data.arr) <- c(dim_data[1:2], 1, 1, dim_data[3:4])
else stop("dimension too small: dim=", timespacedim)
timespacedim <- 4
}
if (!all(MARGIN %in% 1:(length(dim_data) - 2))) stop("MARGIN out of range.")
if (any(MARGIN.slices %in% MARGIN.movie))
stop("MARGIN.slices and MARGIN.movie are not disjoint.")
if (length(MARGIN.slices) < 1)
MARGIN.slices <-
(1:(max(MARGIN, MARGIN.movie) + 1))[-c(MARGIN, MARGIN.movie)][1]
if (length(MARGIN.movie) < 1)
MARGIN.movie <-
(1:(max(MARGIN, MARGIN.slices) + 1))[-c(MARGIN, MARGIN.slices)][1]
dim_data <- dim(data.arr)
vdimrep <- dim_data[(-1:0) + length(dim_data)]
if (!all(c(MARGIN.movie, MARGIN.slices) %in%
1:(length(dim_data) - 2))) stop("MARGINs out of range.")
xx <- x.grid.vectors[[MARGIN[1]]]
xy <- x.grid.vectors[[MARGIN[2]]]
## reduce the data array by taking a section with respect
## to the dimensions not covered by MARGIN*
mar.vec <- c(MARGIN, MARGIN.slices, MARGIN.movie)
ind <- as.list(rep(1, length(dim_data) - 2))
ind[mar.vec] <- TRUE
data.arr <- do.call("[", c(list(data.arr), ind, TRUE, TRUE, drop=FALSE))
dim(data.arr) <- c(dim_data[sort(mar.vec)], vdimrep)
## re-oredered dimensions such that MARGIN and MARGIN.slices
## and MARGIN.movie are the first 4 dimensions
perm.tmp <- c(mar.vec, (-1:0) + length(dim_data))
data.arr <- aperm(data.arr, perm.tmp)
dim_data <- dim(data.arr)
NEWMARGIN <- 1:2
MARGIN.slices <- 3
MARGIN.movie <- 4
if (do.slices) {
if (n != 1) {
n <- 1
message("only first realization is shown")
}
if (plot.variance){
plot.variance <- FALSE
message("plot.variance was set to FALSE")
}
mar.len <- dim_data[MARGIN.slices]
if (n.slices[length(n.slices)] > mar.len)
n.slices[length(n.slices)] <- mar.len
slices.ind <-
if (length(n.slices) == 1) seq(1, mar.len, length=n.slices)
else seq(n.slices[1], n.slices[2], length=n.slices[3])
slices.ind <- unique(round(slices.ind))
slices.ind <- slices.ind[slices.ind >= 1 & slices.ind <= mar.len]
## which indices in the slices dimension are taken
} else {
slices.ind <- 1
## the first dimension which is not in MARGIN
}
n.slices <- length(slices.ind)
## ersten n.orig-1 sind wiederholungen, die letzte 'Spalte'
## ist die Varianz falls existent
data.idx <- 1 : (n.ohne.var*vdim)
all.i <- as.matrix(expand.grid(1:n.slices, 1:n)[2:1]) ## i, ii
coords <- as.matrix(expand.grid(xx, xy))
m.range <- if (do.movie) 1:dim_data[MARGIN.movie] else 1
} else { ## not grid
vdim <- x@.RFparams$vdim
n <- min(x@.RFparams$n, nmax) + plot.variance
nc <- ncol(x@data)
if (nc < n*vdim)
if (n==1) vdim <- nc else if (vdim==1) n <- nc else {
stop("ncol(x@data) does not match 'x@.RFparams'; change 'x@.RFparams'")
}
data.idx <- 1:(x@.RFparams$n*vdim)
all.i <- cbind(1:n, 1)
genuine.timespacedim <- ncol(x@coords)
coords <- x@coords[, MARGIN]
m.range <- 1
}
if (!(missing.y <- missing(y))) {
if (do.slices)
stop("'y' and 'MARGIN.slices' may not be given at the same time")
#
## eigentlich hier UnifyData
if (is(y, 'RFspatialGridDataFrame')) {
y.coords <- as(y, "RFspatialPointsDataFrame")@coords
y.data <- y@data
} else if (is(y, "matrix") || is(y, "data.frame")) {
dc <- data.columns(data=y, xdim = dimensions(x), force=TRUE)
y.coords <- y[, dc$is.x, drop=FALSE]
y.data <- y[, dc$is.data, drop=FALSE]
# Print(dc, y, x, dimensions(x), dc, y.coords, y.data)
} else {
y.coords <- y@coords
y.data <- y@data
}
}
data.range <-
apply(as.matrix(1:vdim), 1, # statt data.idx # pro vdim eine legend
function(z) {
## Print(z, missing.y)
d <- if (missing.y) x@data[z + vdim * 0:(n-plot.variance-1)]
else {
idx <- z + vdim * 0:(n-plot.variance-1)
## Print(idx,z,vdim,n,plot.variance,idx[idx <= ncol(y.data)],y.data)
c(#x@data[idx],
y.data[, idx[idx <= ncol(y.data)]])
}
## Print(d, range(d, na.rm=TRUE))
range(d,na.rm=TRUE)
})
## Print(data.range)
var.range <- if (plot.variance) sapply(x@data[-data.idx],
range, na.rm=TRUE) else NULL
if (missing(select.variables)) select.variables <- 1:vdim
image.par <- prepareplotRFsp(x=x, vdim=vdim, select=select.variables,
data.range = data.range, var.range=var.range,
plot.var=plot.variance, MARGIN=NEWMARGIN,
n=n, n.slices=n.slices, plot.legend=legend,
zlim=zlim,
...)
image.par$names.vdim <-
add.units(image.par$names.vdim, x@.RFparams$varunits)
legends <- image.par$legends
if (x.grid) {
nx.vectors <- min(length(xx), image.par$arrow$nx.vectors)
thinning <- as.integer( (length(xx)-1) / nx.vectors)
} else {
nx.vectors <- min(nrow(coords), image.par$arrow$nx.vectors^2)
thinning <- as.integer( (nrow(coords)-1) / nx.vectors^2)
}
## split the left part according to 'split.main' for different vdims and
## repetitions
current <- dev.cur()
if (do.avi <- as.integer(do.movie && length(file) > 0)) {
ans <- system("mencoder")
if (ans != 0 && ans != 1) stop("'mencoder' needs to be installed first.")
digits <- 1 + ceiling(log(max(m.range)) / log(10))
fn <- character(max(m.range))
}
if (!graphics$split_screen) {
if (graphics$always_open_device) par(oma=image.par$oma)
else if (all(par()$oma == 0) &&
(any(par()$mfcol != 1) || any(par()$mfrow != 1)))
stop("par()$oma has not been set; 'oma=rep(2,4)' is a good choice.")
}
for (m in m.range) {
if (do.avi) {
fn[m] <- paste(file, "__", formatC(m, width=digits, flag="0",
format="d"), ".png", sep="")
if (file.exists(fn[m])) stop(fn[m], "already exists.");
png(height=height.pixel, width=width.pixel, filename=fn[m])
filedev <- dev.cur()
par(mfcol=image.par$split.main, mar=c(.2, .2, .2, .2))
dev.set(current)
} else filedev <- dev.cur()
for (jx in 1:length(select.variables)) {
j <- if (is.list(select.variables)) select.variables[[jx]]
else select.variables[jx]
for (ix in 1:nrow(all.i)) {
i <- all.i[ix, ]
dots <- dots.with.main.lab <- image.par$dots
main <- dots$main
dots$main <- NULL
lab <- xylabs("", "", units=x@.RFparams$coordunits)
dots$xlab <- lab$x
dots$ylab <- lab$y
if (do.plot.var <- (plot.variance && i[1]==n)){
k <- if (x.grid) n.orig else x@.RFparams$n + 1;
dv <- "var"
} else {
k <- i[1]
dv <- "data"
}
if (graphics$split_screen) {
screen(image.par$scr.main[ix, jx])
par(oma=image.par$oma)
}
par(mar=image.par$mar)
len.col <- length(image.par[[dv]]$col)
col <- image.par[[dv]]$col[[ 1 + (j[1]-1) %% len.col]]
breaks <- image.par[[dv]]$breaks[, j[1]]
genuine.image <- (length(j) == 1 || length(j)==3)
if (x.grid) {
dots$type <- NULL
dots$col <- if (genuine.image) col else par()$bg
for (devices in 0:do.avi) {
args <- c(dots, list(x=xx, y=xy, z=data.arr[,,i[2], m, j[1], k],
zlim = image.par[[dv]]$range[, j[1]],
axes = plotmethod == "persp"))
plot.return <- do.call(plotmethod, args=args)
dev.set(filedev)
}
dev.set(current)
} else {
idx <- if (n==1) j else if (vdim==1) k else (k-1)*vdim+j
dots$col <- if (genuine.image)
col[ cut(x@data[,idx[1]], breaks=breaks) ] else par()$bg
for (devices in 0:do.avi) {
do.call(graphics::plot,
args=c(dots, list(x=coords[, 1], y=coords[, 2],
axes=FALSE)))
box()
dev.set(filedev)
}
dev.set(current)
}
if (image.par$legend && ix == 1 && legends$do[jx]) {
leg <- legends[[dv]]$z.legend[, j[1]]
if (graphics$split_screen) {
screen(legends[[dv]]$scr[jx])
lab <- xylabs("", "", units=legends$units)
image(x=leg, y=c(0,1),
z=matrix(ncol=2, rep(leg, 2)),
axes=FALSE, xlab=lab$x, ylab=lab$y,
col=legends[[dv]]$col[[jx]]
)
axis(3, mgp=if (do.plot.var) c(3,0,0),
hadj=if (do.plot.var) -0.5 else NA)#1 + 2 * (dv =="data"))
box()
screen(image.par$scr.main[ix, jx])
} else { ## not split.screen
my.legend(min(xx), max(xy), image.par[[dv]]$range[, j[1]],
col=legends[[dv]]$col[[jx]], bg="white")
}
}
for (devices in 0:do.avi) {
if (n.slices > 1)
legend("bottomright", bty="n",
legend=paste(image.par$names.coords[MARGIN.slices], "=",
x.grid.vectors[[MARGIN.slices]][slices.ind[i[2]]]))
if (do.plot.arrows <- length(j) >= 2 && !do.plot.var) {
jj <- if (length(j) == 3) j[-1] else jj <- j
rx <- range(coords[, 1])
ry <- range(coords[, 2])
col.arrow <- if (length(image.par[["data"]]$col) >= jj[1] &&
length(image.par[["data"]]$col[[jj[1]]]) == 1)
image.par[["data"]]$col[[jj[1]]] else "black"
if (ix == 1) { ## to do: document in a paper?
factor <- image.par$arrow$reduction *
sqrt(diff(rx) * diff(ry) / max(x@data[jj[1]]^2 +
x@data[jj[2]]^2)) / nx.vectors
}
my.arrows(coords, x@data[jj], r = factor, thinning = thinning,
col = col.arrow,
nrow = if (x.grid) length(xx))
}
if (!do.plot.var && !missing.y && (length(j)==1 || (length(j)==3))) {
idx <- if (n==1) j else if (vdim==1) i[1] else (i[1]-1)*vdim+j
if (ncol(y.data) < idx) idx <- 1
if (plotmethod == "persp") {
# theta = 30, phi = 30, expand = 0.5,
xy <- trans3d(y.coords[, MARGIN[1]], y.coords[, MARGIN[2]],
data[ , idx], pmat=plot.return)
points(xy, pch=16, col="black")
} else {
col2 <- col[ cut(y.data[ , idx], breaks=breaks) ]
dots2 <- dots
dots2[c("type", "pch", "lty", "col", "bg", "cex", "lwd")] <- NULL
addpoints <- function(pch, col, cex) {
do.call(graphics::plot.xy,
args=c(dots2,
list(xy=xy.coords(y.coords[, MARGIN[1]],
y.coords[, MARGIN[2]]),
type="p", pch=pch, lty=1, col=col, bg=NA,
cex=cex, lwd=1)))
}
if (plotmethod=="image") addpoints(15, "darkgray", dots$cex*2)
addpoints(dots$pch, col2, dots$cex) ## causes error in
} # not persp
} # !do.plot.var
if (ix==1 ||
((image.par$split.main[1] != nrow(all.i)) &&
(ix <= image.par$split.main[2]))) {
## nrow(all.i) || #!image.par$always.close ||
axis(1, outer=TRUE)#image.par$always.close
}
if (jx==1 &&
((image.par$split.main[2] == length(select.variables)) ||
((ix-1) %% image.par$split.main[2] == 0))) # !image.par$always.close ||
axis(2, outer=TRUE)#image.par$always.close)
if (all(i==1) && (image.par$grPrintlevel > 1 || vdim>1)) {
mtext(text = image.par$names.vdim[jx], # names(x)[j[1]]
side=3, line=-1,
col = image.par$text.col, cex=dots$cex)
}
if (n>1 && jx==1){
mtext(text = image.par$names.rep[ix], side=3, line=-2, cex=dots$cex)
}
dev.set(filedev)
}
dev.set(current)
if (image.par$legend && ix == 1) {
if (do.plot.arrows) {
## do not merge with ix==1 above !!
## reason: screen is changed here and going back
## is not a good idea
len <- max(pretty(diff(rx) / image.par$arrows$nx.vectors/2 /factor))
if (graphics$split_screen) {
x.arrow <- cbind(mean(rx),
image.par$arrows$leg.pos[1+genuine.image])
screen(image.par$scr.legends[jx])
do.call(graphics::plot, args=c(dots, list(x=Inf, y=Inf,
xlim=rx, ylim=c(0,1), axes=FALSE)))
colArrow <- col.arrow
} else {
dy <- diff(range(xy))
xl <- max(xx) - 0.05 * diff(range(xx))
yl <- max(xy) - 0.02 * dy
points(rep(xl, 2), rep(yl-0.01 * dy, 2), pch=c(16, 1), cex=7,
col=c("white", "black"))
x.arrow <- cbind(xl, yl)
colArrow <- "red"
}
my.arrows(x.arrow, cbind(len, 0), r = factor,
thinning=0, col=colArrow)
text(x.arrow, pos=1, labels = len, col=colArrow)
}
}
} # ix (rows)
} # jx
dots.with.main.lab$type <- NULL # woher kommt dieses type??
dots.with.main.lab$zlab <- NULL
## falls nicht auf NULL gesetzt gibt es einen Fehler. Warum?
do.call(graphics::title,
args=list(main=dots.with.main.lab$main,
outer=TRUE, line=image.par$oma[3]-1.5))
dots.with.main.lab$main <- NULL
do.call(graphics::title,
args=c(dots.with.main.lab, list(outer=TRUE, line=NA)))
if (image.par$grPrintlevel > 0) {
if (graphics$split_screen) {
screen(image.par$scr[1 + image.par$legend], new=FALSE)
PlotTitle(x, if (is.null(main)) "" else main)
} #else if (!is.null(main)) title(main=main)
}
if (do.avi) {
dev.off(filedev)
dev.set(current)
}
} # m in m.range
if (do.avi) {
txt <- paste("mencoder -mf fps=30 -ffourcc DX50 -ovc lavc ",
" -speed ", speed,
" -lavcopts vcodec=mpeg4:vbitrate=9800:aspect=4/3:vhq:keyint=15",
" -vf scale=720:576 -o ", file, ".avi mf://",
file, "__*.png", sep="")
system(txt)
file.remove(fn)
}
scr <- image.par[c("scr.main", "scr.legends", "scr", "split.main")]
if (graphics$split_screen && graphics$close_screen){
close.screen(unlist(scr))
scr <- NULL
}
return(invisible(scr))
}
trafo_pointsdata <- function(x, dim) {
if (isgrid <- is(x, "RFgridDataFrame")) {
x <- grid2pts1D(x) ## x <- as(x, "RFpointsDataFrame") # funktionierte nicht
} else if ((is(x, "matrix") || is(x, "data.frame")) && !missing(dim)) {
dc <- data.columns(data=x, xdim = dim, force=TRUE)
x <- list(coords=x[, dc$is.x, drop=FALSE], data=x[, dc$is.data, drop=FALSE])
} else {
if (!is(x, "RFpointsDataFrame"))
stop("method only for objects of class 'RFpointsDataFrame' and 'RFgridDataFrame'")
}
dummy <- dimnames(x@coords)[[2]][1]
lab <- xylabs(if (is.null(dummy)) "" else dummy, "",
units=x@.RFparams$coordunits)
labdata <- names(x@data)
colname <- colnames(x@data)
if (isgrid) {
return(list(coords=as.vector(x@coords),
data=as.matrix(x@data),
RFparams=x@.RFparams,
lab=lab, labdata=labdata, colnames=colname))
} else {
ord <- order(x@coords)
return(list(coords=x@coords[ord, ],
data=as.matrix(x@data)[ord, , drop=FALSE],
RFparams=x@.RFparams,
lab=lab, labdata=labdata, colnames=colname))
}
}
RFplotSimulation1D <- function(x, y, nmax=6,
plot.variance=!is.null(x@.RFparams$has.variance) &&
x@.RFparams$has.variance,
legend=TRUE, ...) {
## grid : sorted = TRUE
## points : sorted = FALSE
stopifnot(!missing(x))
x <- trafo_pointsdata(x)
nc <- ncol(x$data)
if (!missing(y)) {
y <- trafo_pointsdata(y, dimensions(dim))
y$data <- rep(y$data, length.out=nrow(y$data) * nc)
dim(y$data) <- c(length(y$coords), nc)
}
has.variance <- !is.null(x$RFparams$has.variance) && x$RFparams$has.variance
if (!has.variance) plot.variance <- FALSE
n <- min(x$RFparams$n, nmax) + plot.variance
vdim <- x$RFparams$vdim
if (nc < n*vdim) {
if (n==1) vdim <- nc else if (vdim==1) n <- nc else {
stop("ncol(x@data) does not match 'x@.RFparams'; change 'x@.RFparams'")
}
}
graphics <- RFoptions()$graphics
ArrangeDevice(graphics, c(1, n)) ## NIE par vor ArrangeDevice !!!!
dots <- mergeWithGlobal(list(...))
dotnames <- names(dots)
if ("bg" %in% dotnames) {
par(bg=dots$bg)
dots$bg <- NULL
}
if (!("xlab" %in% dotnames)) dots$xlab <- x$lab$x
if (!("type" %in% dotnames)) dots$type <- "l"
make.small.mar <- ("xlab" %in% dotnames &&
is.null(dots$xlab) && is.null(dots$ylab))
## variable names
if (!is.null(x$labdata) && all(nchar(x$labdata)>0))
names.vdim <- unlist(lapply(strsplit(x$labdata[1:vdim], ".n"),
FUN=function(li) li[[1]]))
else {
names.vdim <- paste("variable", 1:vdim)
x$labdata <- names.vdim
}
if (n>1){
ylab.vec <- c(paste("realization ", 1:(n-plot.variance), sep=""),
if (plot.variance) "kriging variance")
} else {
ylab.vec <- if (vdim==1) x$colnames else ""
}
if ("ylab" %in% dotnames) {
if (!is.null(dots$ylab))
ylab.vec[1:length(ylab.vec)] <- dots$ylab
dots$ylab <- NULL
}
col <- 1:vdim
if ("col" %in% dotnames) {
if (!is.null(dots$col))
col[1:length(col)] <- dots$col
dots$col <- NULL
}
if (graphics$split_screen) scr <- split.screen(c(n,1))
else {
scr <- NULL
par(mfrow=c(n, 1), mar=c(1, 1, 0.1, 0.1))
}
for (i in 1:n){
if (graphics$split_screen) screen(i)
if (make.small.mar) {
if (graphics$split_screen) par(oma=c(3,0,1,1)+.1, mar=c(0,3,0,0))
else par(oma=rep(0,4), mar=c(3, 3, 1, 1), cex=0.6)
} else par(oma=c(4,0,1,1)+.1, mar=c(0,4,0,0))
ylab <- ylab.vec[i]
if (tmp.idx <- (plot.variance && i==n)){
i <- x$RFparams$n + plot.variance
}
do.call(graphics::matplot,
args=c(dots,
list(
x=x$coords, y=x$data[ , vdim*(i-1)+(1:vdim)],
xaxt="n", yaxt="n", ylab=ylab, col=col))
)
if (!missing(y)) {
points(x=y$coords, y=y$data[ , vdim*(i-1)+(1:vdim)], pch=22, col="red")
}
axis(2)
if (tmp.idx) i <- n
if (i==1) {
if ( (vdim > 1) && legend) {
legend("topright", col=col, lty=1, legend = c(names.vdim))
}
} else if (i==n) {
axis(1, outer=n>1)
title(xlab=dots$xlab, outer=TRUE)
} else axis(1, labels=FALSE)
}
if (graphics$close_screen) {
close.screen(scr)
scr <- NULL
}
return(invisible(scr))
}
errMsgNoPlotAvailable <- function(x, y)
warning(paste("no plot method available for signature c(",
class(x), ",", class(y), ")"))
setMethod(f="plot", signature(x="RFgridDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation1D(x, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation1D(x, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation(x, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="missing"),
definition=function(x, y, ...) RFplotSimulation(x, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="matrix"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFspatialGridDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame", y="data.frame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="RFgridDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFgridDataFrame", y="RFpointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="RFgridDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot", signature(x="RFpointsDataFrame", y="RFpointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation1D(x, y, ...))
setMethod(f="plot",
signature(x="RFspatialGridDataFrame", y="RFspatialGridDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot",
signature(x="RFspatialGridDataFrame", y="RFspatialPointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="plot", signature(x="RFspatialPointsDataFrame",
y="RFspatialGridDataFrame"),
definition=function(x, y, ...) {
errMsgNoPlotAvailable(x, y)
return(invisible(NULL))
})
setMethod(f="plot",
signature(x="RFspatialPointsDataFrame", y="RFspatialPointsDataFrame"),
definition=function(x, y, ...) RFplotSimulation(x, y, ...))
setMethod(f="persp",
signature(x="RFspatialGridDataFrame"),
definition=function(x, ..., zlab="")
RFplotSimulation(x, ..., zlab=zlab, plotmethod="persp"))
contour.RFspatialGridDataFrame <- function(x, ...)
RFplotSimulation(x, ..., plotmethod="contour")
Try the RandomFields package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.