Nothing
R/RMmodels-Methods-plots.R
In RandomFields: Simulation and Analysis of Random Fields
Defines functions
list2RMmodel
lines.RMmodel
points.RMmodel
RFplotModel
singleplot
preparePlotRMmodel
rfConvertRMmodel2string
print.RMmodelgenerator
print.RMmodel
print.RM_model
print.summary.RMmodel
summary.RM_model
summary.RMmodel
str.RMmodel
XresolveRight
XresolveLeft
Xresolve
resolveLeft
resolveRight
resolve
accessReplaceSlotsByName
accessSlotsByName
Documented in
lines.RMmodel
points.RMmodel
print.RMmodel
print.RMmodelgenerator
RFplotModel
str.RMmodel
## Authors
## Martin Schlather, schlather@math.uni-mannheim.de
##
##
## Copyright (C) 2015 -- 2017 Alexander Malinowski & Martin Schlather
## Copyright (C) 2017 -- 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.
## accessing CLASS_CLIST and RMmodelgenerator via '['-operator
# e.g. RMwhittle["domain"]
accessSlotsByName <- function(x,i,j,drop=FALSE) {
names <- slotNames(x)
if (!(i %in% names))
stop(paste(i, "is not a valid slot specification"))
return(slot(x, i))
}
accessReplaceSlotsByName <- function(x,i,j,value) {
names <- slotNames(x)
if (!(i %in% names))
stop(paste(i, "dis not a valid slot specification"))
else
slot(x, i) <- value
validObject(x)
return(x)
}
setMethod(f="[", signature = CLASS_CLIST, def = accessSlotsByName)
setMethod(f="[", signature = CLASS_FIT, def = accessSlotsByName)
setMethod(f="[", signature = CLASS_RM, def = accessSlotsByName)
setReplaceMethod(f="[", signature = CLASS_CLIST, accessReplaceSlotsByName)
setReplaceMethod(f="[", signature = CLASS_FIT, accessReplaceSlotsByName)
setReplaceMethod(f="[", signature = CLASS_RM,accessReplaceSlotsByName)
## summing up RMmodels
setMethod('c', signature=c(CLASS_CLIST),
function(x, ..., recursive = FALSE) R.c(x, ...) )
## funktioniert im speziellen Modus nicht, allgemein schon
## warum ist unklar
#setMethod('diag', signature=c(CLASS_CLIST, 'missing', 'missing', 'missing'),
# function(x=1, nrow, ncol, names=TRUE) {
# ## Print("hier"); str(x)
# RMmatrix(x)
# })
resolve <- function(e1, e2, sign) {
## RMmodels only
d <- list()
if (e1@name==sign && (len.e1 <- length(e1@submodels)) < MAXSUB) {
for (i in 1:len.e1) d[[i]] <- e1@submodels[[i]]
} else {
len.e1 <- 1
d[[1]] <- if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
# do.call(SYMBOL_P, list(e1))
else e1
}
d[[len.e1 + 1]] <-
(if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
# do.call(SYMBOL_P, list(e2))
else e2)
if (sign == RM_MULT[1]) {
# print(d)
model <- do.call(sign, d)
} else model <- do.call(sign, d)
return(model)
}
warn.resolve.txt <- "A large vector consists fully of NAs -- the model is probably not correct.\nNote that it is always better to define the covariance model in the first\nsummands and then the trend. Also better use explicitely 'R.c', 'RMcovariate'\nand 'R.const' if the model is more complicated"
resolveRight<- function(e1, e2, sign) {
## left constant
d <- list()
if (e1@name==sign && (len.e1 <- length(e1@submodels)) < MAXSUB) {
for (i in 1:len.e1) d[[i]] <- e1@submodels[[i]]
} else {
len.e1 <- 1
d[[1]] <- (if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
}
d[[len.e1 + 1]] <-
if (is.list(e2)) do.call(R_C, e2)
else if (length(e2)==1) do.call(R_CONST, list(e2))
else if (!all(is.finite(e2))) {
if (all(is.na(e2)) && length(e2)>5) warning(warn.resolve.txt)
do.call(R_C, list(e2))
} else if (sign == RM_PLUS[1]) {
tmpList <- list(RM_COVARIATE)
tmpList[[COVARIATE_C_NAME]] <- e2
tmpList[[COVARIATE_X_NAME]] <- NULL
tmpList[[COVARIATE_ADDNA_NAME]] <- TRUE
do.call(RM_COVARIATE, tmpList)
} else do.call(R_C, list(e2))
## Version brasilienc
## if (length(e2)==1) d[[len.e1 + 1]] <- do.call(R_CONST, list(e2))
## else {
## e <- list(e2)
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[len.e1 + 1]] <- do.call(RM_COVARIATE, e)
## }
model <- do.call(sign, d)
return(model)
}
resolveLeft<- function(e1, e2, sign) {
## right constant
d <- list()
len.e1 <- 1
## Version Brasilien
# if (length(e1)==1) d[[1]] <- do.call(R_CONST, list(e1))
# else {
# e <- list(e1)
# e[[COVARIATE_ADDNA_NAME]] <- TRUE
# d[[1]] <- do.call(RM_COVARIATE, e)
# }
d[[1]] <- if (is.list(e1)) do.call(R_C, e1)
else if (length(e1)==1) do.call(R_CONST, list(e1))
else if (!all(is.finite(e1))) {
if (all(is.na(e1)) && length(e1)>5) warning(warn.resolve.txt)
do.call(R_C, list(e1))
} else if (sign == RM_PLUS[1]) {
tmpList <- list(RM_COVARIATE)
tmpList[[COVARIATE_C_NAME]] <- e1
tmpList[[COVARIATE_X_NAME]] <- NULL
tmpList[[COVARIATE_ADDNA_NAME]] <- TRUE
do.call(RM_COVARIATE, tmpList)
} else do.call(R_C, list(e1))
d[[len.e1 + 1]] <- (if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
##do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(sign, d)
return(model)
}
## summing up RMmodels
setMethod('+', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'factor'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'list'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('numeric', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('logical', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('data.frame', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('factor', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('character', CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
## multiplying RMmodels
setMethod('*', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('numeric', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('logical', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) resolveRight(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) resolveRight(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('character', CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
Xresolve <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
d[[1]] <-
(if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
d[[len.e1 + 1]] <-
( if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(model, d)
return(model)
}
XresolveLeft <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
if (length(e1)==1) d[[1]] <- do.call(R_CONST, list(e1))
else {
e <- list(e1)
d[[1]] <- do.call(R_CONST, e)
## version brasilien
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[1]] <- do.call(RM_COVARIATE, e)
}
d[[len.e1 + 1]] <- (if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(model, d)
return(model)
}
XresolveRight <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
d[[1]] <- (if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
if (length(e2)==1) d[[len.e1 + 1]] <- do.call(R_CONST, list(e2))
else {
e <- list(e2)
d[[len.e1 + 1]] <- do.call(R_CONST, e)
## version brasilien
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[len.e1 + 1]] <- do.call(RM_COVARIATE, e)
}
model <- do.call(model, d)
return(model)
}
## substracting RMmodels
setMethod('-', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
setMethod('-', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.minus"))
setMethod('-', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
setMethod('-', signature=c('character', CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
## dividing up RMmodels
setMethod('/', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.div"))
setMethod('/', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.div"))
setMethod('/', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.div"))
setMethod('/', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.div"))
setMethod('/', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.div"))
setMethod('/', signature=c('RMmodel', 'character'),
function(e1, e2) Xresolve(e1, e2, "R.div"))
setMethod('/', signature=c('character', 'RMmodel'),
function(e1, e2) Xresolve(e1, e2, "R.div"))
## powering up RMmodels
setMethod('^', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
setMethod('^', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.pow"))
setMethod('^', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.pow"))
setMethod('^', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.pow"))
setMethod('^', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.pow"))
setMethod('^', signature=c('RMmodel', 'character'),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
setMethod('^', signature=c('character', 'RMmodel'),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
## str, print and show
## str.RMmodel is basically copied from str.default, but where
## those slots of 'par.general' are excluded from being printed
## for which the value is 'RFdefault', i.e. for which there is no
## explicit value given
str.RMmodel <-
function(object, max.level = NA, vec.len = strO$vec.len,
digits.d = strO$digits.d,
nchar.max = 128, give.attr = TRUE, give.head = TRUE,
give.length = give.head,
width = getOption("width"), nest.lev = 0,
indent.str = paste(rep.int(" ",
max(0, nest.lev + 1)), collapse = ".."),
comp.str = "$ ", no.list = FALSE, envir = baseenv(),
strict.width = strO$strict.width,
drop.deparse.attr = strO$drop.deparse.attr,
formatNum = strO$formatNum, list.len = 99, ...)
{
oDefs <- c("strict.width", "vec.len", "digits.d", "drop.deparse.attr",
"formatNum")
strO <- getOption("str")
if (!is.list(strO)) {
warning("invalid options('str') -- using defaults instead")
strO <- strOptions()
}
else {
if (!all(names(strO) %in% oDefs))
warning("invalid components in options('str'): ",
paste(setdiff(names(strO), oDefs), collapse = ", "))
strO <- modifyList(strOptions(), strO)
}
strict.width <- match.arg(strict.width, choices = c("no", "cut", "wrap"))
if (strict.width != "no") {
ss <- capture.output(str(object, max.level = max.level, #
vec.len = vec.len, digits.d = digits.d,
drop.deparse.attr = drop.deparse.attr,
nchar.max = nchar.max,
give.attr = give.attr,
give.head = give.head,
give.length = give.length,
width = width, nest.lev = nest.lev,
indent.str = indent.str,
comp.str = comp.str,
no.list = no.list || is.data.frame(object),
envir = envir, strict.width = "no", ...))
if (strict.width == "wrap") {
nind <- nchar(indent.str) + 2
ss <- strwrap(ss, width = width, exdent = nind)
}
if (any(iLong <- nchar(ss) > width))
ss[iLong] <- sub(sprintf("^(.{1,%d}).*", width - 2), "\\1..", ss[iLong])
cat(ss, sep = "\n")
return(invisible())
}
oo <- options(digits = digits.d)
on.exit(options(oo))
le <- length(object)
P0 <- function(...) paste(..., sep = "")
`%w/o%` <- function(x, y) x[is.na(match(x, y))]
nfS <- names(fStr <- formals())
strSub <- function(obj, ...) {
nf <- nfS %w/o% c("object", "give.length", "comp.str",
"no.list", names(match.call())[-(1:2)], "...")
aList <- as.list(fStr)[nf]
aList[] <- lapply(nf, function(n) eval(as.name(n)))
if ("par.general" %in% names(obj)){
is.RFdefault <-
unlist(lapply(obj$par.general,
FUN=function(x){
!is(x, CLASS_CLIST) && !is.na(x) && x==RM_DEFAULT
}))
obj$par.general[is.RFdefault] <- NULL
if (all(is.RFdefault)) obj$par.general <- list()
}
do.call(utils::str, c(list(object = obj), aList, list(...)),
quote = TRUE)
}
v.len <- vec.len
std.attr <- "names"
cl <- if ((S4 <- isS4(object)))
class(object)
else oldClass(object)
has.class <- S4 || !is.null(cl)
mod <- ""
char.like <- FALSE
if (give.attr)
a <- attributes(object)
if (is.null(object))
cat(" NULL\n")
else if (S4) {
a <- sapply(methods::.slotNames(object), methods::slot,
object = object, simplify = FALSE)
cat("Formal class", " '", paste(cl, collapse = "', '"),
"' [package \"", attr(cl, "package"), "\"] with ",
length(a), " slots\n", sep = "")
strSub(a, comp.str = "@ ", no.list = TRUE,
give.length = give.length,
indent.str = paste(indent.str, ".."),
nest.lev = nest.lev + 1)
return(invisible())
}
}
summary.RMmodel <- function(object, max.level=5, ...)
summary(PrepareModel2(object, ...), max.level=max.level)
summary.RM_model <- function(object, ...) {
class(object) <- "summary.RMmodel"
object
}
print.summary.RMmodel <- function(x, max.level=5, ...) {
str(x, no.list=TRUE, max.level = max.level, give.attr=FALSE) #
invisible(x)
}
print.RM_model <- function(x, max.level=5,...) {
print.summary.RMmodel(summary.RM_model(x, max.level=max.level,...),
max.level=max.level)#
}
print.RMmodel <- function(x, max.level=5,...) {
print.summary.RMmodel(summary.RMmodel(x, max.level=max.level, ...),
max.level=max.level)#
}
setMethod(f="show", signature=CLASS_CLIST,
definition=function(object) print.RMmodel(object))#
print.RMmodelgenerator <- function(x, ...) {
cat("*** object of Class '", CLASS_RM, "' ***\n", sep="")
str(args(x@.Data)) ## ok
cat(" type : \t", paste(x@type, collapse=", "), "\n")
cat(" domain : \t", paste(x@domain, collapse=", "), "\n")
cat(" isotropy : \t", paste(x@isotropy, collapse=", "), "\n")
cat(" monotoniciy :\t", paste(x@monotone, collapse=", "), "\n")
cat(" multivariate:\t",
if (x@vdim >= 0) x@vdim
else if (x@vdim == PARAM_DEP) "parameter dependent"
else if (x@vdim == PREVMODEL_DEP) "depends on calling model"
else if (x@vdim == SUBMODEL_DEP) "submodel dependent"
else "specification unclear -- please contact maintainer",
"\n")
cat(" max. dimen. :\t",
if (x@maxdim >= 0) x@maxdim
else if (x@maxdim == PARAM_DEP) "parameter dependent"
else if (x@maxdim == PREVMODEL_DEP) "depends on calling model"
else if (x@maxdim == SUBMODEL_DEP) "submodel dependent"
else "specification unclear -- please contact maintainer",
"\n")
cat(" finite range:\t", x@finiterange, "\n")
cat(" operator : \t", x@operator, "\n")
cat(" simple fctn :\t", x@simpleArguments, "\n")
}
setMethod("show", signature=CLASS_RM,
definition=function(object) print.RMmodelgenerator(object))
rfConvertRMmodel2string <- function(model){
if (!is(model, class2=CLASS_CLIST))
stop("model must be of class '", CLASS_CLIST, "'")
par <- c(model@par.model, model@par.general)
idx.random <- unlist(lapply(par, FUN=isRMmodel))
if (is.null(idx.random)){
param.string <- ""
param.random.string <- ""
} else {
idx.default <- par[!idx.random] == RM_DEFAULT
param.string <- paste(names(par[!idx.random][!idx.default]),
par[!idx.random][!idx.default],
sep="=", collapse=", ")
#if (sum(idx.random) > 0){
string.vector <- lapply(par[idx.random], FUN=rfConvertRMmodel2string)
param.random.string <- paste(names(par[idx.random]), string.vector,
sep="=", collapse=", ")
}
if (length(model@submodels) > 0){
string.vector <- lapply(model@submodels, FUN=rfConvertRMmodel2string)
submodel.string <- paste(names(model@submodels), string.vector,
sep="=", collapse=", ")
if (!(nchar(param.string)==0))
submodel.string <- paste(submodel.string, ", ", sep="")
}
else submodel.string <- ""
string <- paste(model@name, "(", submodel.string, param.random.string,
param.string, ")", sep="")
return(string)
}
## Plot
preparePlotRMmodel <- function(x, xlim, ylim, n.points, dim, fct.type,
MARGIN, fixed.MARGIN, ...){
types <- c("Cov", "Variogram", "Fctn")
## types <- "Fctn"; print("remove")
verballist <- paste("'", types, "'", sep="", collapse="")
if (!missing(fct.type) && length(fct.type) > 0) {
if (!(fct.type %in% types))
stop("fct.type must be NULL or of the types ", verballist)
types <- fct.type
}
all.fct.types <- character(length(x))
all.vdim <- numeric(length(x))
for (i in 1:length(x)) {
fct.type <- types
m <- list("", PrepareModel2(x[[i]]), ...)
while (length(fct.type) > 0 &&
{ m[[1]] <- fct.type[1];
!is.numeric(vdim <- try( InitModel(MODEL_AUX, m, dim),
silent=TRUE))
## Print(CCC)
})
fct.type <- fct.type[-1]
if (!is.numeric(vdim)) {
## Print(vdim, model)
## stop("'vdim' is not numeric")
stop(attr(vdim, "condition")$message)
}
if (vdim[1] != vdim[2]) stop("only simple models can be plotted")
all.vdim[i] <- vdim[1]
all.fct.types[i] <- fct.type[1]
}
if (!all(all.vdim == all.vdim[1]))
stop("models have different multivariability")
# fctcall.vec <- c("Cov", "Variogram")
#covinfo <- RFgetModelInfo(register=MODEL_AUX, level=3, spConform=TRUE)
### Print((covinfo))
# Print(covinfo$domown, TRANS_INV , covinfo$type, isPosDef(covinfo$type),
# is.null(fct.type), fct.type,"Variogram") ; xxx
if (is.null(xlim)) {
xlim <- if (dim > 1 || all.vdim[1] > 1) c(-1, 1) * 1.75 else c(0, 1.75)
}
if (is.null(ylim) && dim > 1) ylim <- xlim
distance <- seq(xlim[1], xlim[2], length=n.points)
if (prod(xlim) <= 0)
distance <- sort(c(if (!any(distance==0)) 0, 1e-5, distance))
if (dim > 1) {
distanceY <- seq(ylim[1], ylim[2], length=n.points)
if (prod(ylim) < 0 & !(any(distanceY==0)))
distanceY <- sort(c(0, distanceY))
}
# Print(covinfo)
# if(covinfo$domown != TRANS_INV)
# stop("method only implemented for models that are not kernels")
if (all(all.fct.types[1] == all.fct.types)) {
switch(all.fct.types[1],
"Cov" = {
main <-"Covariance function"
ylab <- "C(distance)"
},
"Variogram" = {
main <- "Variogram"
ylab <- expression(gamma(distance))
},
"Fctn" = {
main<- ""
ylab <- "f(distance)"
},
stop("method only implemented for ", verballist)
)
} else {
main <- ""
ylab <- "f(distance)"
}
if (length(x) == 1) {
for.what <- rfConvertRMmodel2string(x[[1]])
if (nchar(for.what) > 20) for.what <- strsplit(for.what,"\\(")[[1]][1]
} else {
for.what <- "various models"
}
# main <- paste(main, " plot for ", for.what, "\n", sep="")
main <- paste("plot for ", for.what, "\n", sep="")
if (dim >= 3)
main <- paste(sep="", main, "; component", if (dim>3) "s", " ",
paste((1:dim)[-MARGIN], collapse=", "),
" fixed to the value", if (dim>3) "s", " ",
paste(format(fixed.MARGIN, digits=4), collapse=", "))
return(list(main=main, fctcall=all.fct.types, ylab=ylab, distance=distance,
distanceY = if (dim > 1) distanceY, xlim=xlim, ylim=ylim))
}
singleplot <- function(cov, dim, li, plotmethod, dots, dotnames) {
if (dim==1) {
D <- li$distance
iszero <- D == 0
if (plotmethod == "matplot") {
plotpoint <- any(iszero) && diff(range(dots$ylim)) * 1e-3 <
diff(range(cov)) - diff(range(cov[!iszero]))
if (plotpoint) D[iszero] <- NA
} else plotpoint <- FALSE
liXY <-
if (plotmethod=="plot.xy") list(xy = xy.coords(x=D, y=cov)) ## auch D ?
else list(x=D, y=cov)
## Print(plotmethod, args=c(dots, liXY))
do.call(plotmethod, args=c(dots, liXY))
if (plotpoint) {
for (i in 1:ncol(cov))
points(0, cov[iszero, i], pch=19 + i, col = dots$col[i])
}
} else {
if (!("zlim" %in% dotnames)) dots$zlim <- range(unlist(cov), finite=TRUE)
addgiven <- "add" %in% dotnames
local.dots <- dots
local.dots$col <- NULL
local.dots$lty <- NULL
is.contour <- is.character(plotmethod) && plotmethod == "contour"
if (!is.contour) {
if (ncol(cov) > 1)
stop("several models can be plotted at once only with 'contour'")
col <- default.image.par(dots$zlim, NULL)$data$default.col
}
for (i in 1:ncol(cov)) {
if (!addgiven && is.contour) local.dots$add <- i > 1
do.call(plotmethod,
args=c(list(x=li$distance, y=li$distanceY,
col=if (is.contour) dots$col[i] else col,
lty = dots$lty[i],
z=matrix(cov[, i], nrow=length(li$distance))), local.dots))
}
}
}
RFplotModel <- function(x, y, dim=1,
n.points=
if (dim==1 || is.contour) 200 else 100,
fct.type=NULL,
MARGIN, fixed.MARGIN,
maxchar=15, ...,
plotmethod=if (dim==1) "matplot" else "contour") {
is.contour <- is.character(plotmethod) && plotmethod == "contour"
RFopt <- RFoptions()
if (ex.red <- RFopt$internal$examples_reduced)
n.points <- as.integer(min(n.points, ex.red - 2))
stopifnot(length(dim)==1)
if (!(dim %in% 1:10))
stop("only 'dim==1', 'dim==2' and 'dim==3' are allowed")
if (dim==3)
if (missing(MARGIN) || missing(fixed.MARGIN))
stop("'MARGIN' and 'fixed.MARGIN' must be given if dim >=3")
if ((!missing(MARGIN)) || (!missing(fixed.MARGIN))) {
stopifnot((!missing(MARGIN)) && (!missing(fixed.MARGIN)))
if (dim < 3)
stop("'MARGIN' and 'fixed.MARGIN' should only be given for dim>=3")
stopifnot(is.numeric(MARGIN) && length(MARGIN)==2)
stopifnot(is.numeric(fixed.MARGIN) && (length(fixed.MARGIN) == dim - 2))
}
dots <- list(...)
dotnames <- names(dots)
models <- substr(dotnames, 1, 5) == "model"
x <- c(list(x), dots[models])
mnames <- c("", substr(dotnames[models], 6, 100))
idx <- substr(mnames, 1, 1) == "."
mnames[idx] <- substr(mnames[idx], 2, 1000)
for (i in which(!idx)) {
mnames[i] <- rfConvertRMmodel2string(x[[i]])
nmn <- nchar(mnames[i]) - 1
if (substr(mnames[i], nmn, nmn) == "(") {
mnames[i] <- substr(mnames[i], 1, nmn - 1)
}
msplit <- strsplit(mnames[i], "RM")[[1]]
if (length(msplit) == 2 && msplit[1]=="") mnames[i] <- msplit[2]
}
mnames <- substr(mnames, 1, maxchar)
dots <- mergeWithGlobal(dots[!models])
dotnames <- names(dots)
if (!("type" %in% dotnames)) dots$type <- "l"
li <- preparePlotRMmodel(x=x, xlim=dots$xlim, ylim=dots$ylim,
n.points=n.points, dim=dim,
fct.type=fct.type,
MARGIN=MARGIN, fixed.MARGIN=fixed.MARGIN)
dots$xlim <- li$xlim
if (!is.null(li$ylim)) dots$ylim <- li$ylim
if (!("main" %in% dotnames)) dots$main <- li$main
if (!("cex" %in% dotnames)) dots$cex <- 1
if (!("cex.main" %in% dotnames)) dots$cex.main <- 1.3 * dots$cex
if (!("cex.axis" %in% dotnames)) dots$cex.axis <- 1.0 * dots$cex
if (!("cex.lab" %in% dotnames)) dots$cex.lab <- 1.0 * dots$cex
if (!("col" %in% dotnames)) dots$col <- rep(1:7, length.out=length(x))
cov <- list()
if (dim==1) {
for (i in 1:length(x))
cov[[i]] <- rfeval(x=li$distance, model=x[[i]], fctcall=li$fctcall[i])
#print(cov, li$distance)
lab <- xylabs("distance", li$ylab)
## strokorb monotone ist z.B. nicht ueberall finite:
if (!("ylim" %in% dotnames)) dots$ylim <- range(0, unlist(cov), finite=TRUE)
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
} else {
lab <- xylabs("", "")
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
dots$type <- NULL
if (dim==2) {
di <- as.matrix(expand.grid(li$distance, li$distanceY))
for (i in 1:length(x)) {
cov[[i]] <- rfeval(x=di, model=x[[i]], fctcall=li$fctcall[i])
}
} else if (dim>=3) {
m1 <- expand.grid(li$distance, li$distanceY)
m2 <- matrix(NA, ncol=dim, nrow=nrow(m1))
m2[,MARGIN] <- as.matrix(m1)
m2[,-MARGIN] <- rep(fixed.MARGIN, each=nrow(m1))
for (i in 1:length(x))
cov[[i]] <- rfeval(x=m2, model=x[[i]], fctcall=li$fctcall[i])
} else stop("this error should never appear")
}
if ((is.null(dots$xlab) || dots$xlab=="") &&
(is.null(dots$ylab) || dots$ylab=="")) {
margins <- c(3, 3, if (dots$main=="") 0 else 2, 0) + 0.2
} else {
margins <- c(5, 5, if (dots$main=="") 0 else 2, 0) + 0.2
}
dimcov <- dim(cov[[1]])
graphics <- RFopt$graphics
if (plotmethod != "plot.xy") { ### points and lines !!
if (is.null(dimcov)) { ## i.e. vdim == 1
ArrangeDevice(graphics, c(1,1))
} else {
figs <- dimcov[2:3]
ArrangeDevice(graphics, figs)
}
}
scr <- NULL
if (is.null(dimcov)) { ## i.e. vdim == 1
cov <- sapply(cov, function(x) x)
if (!("lty" %in% dotnames)) dots$lty <- 1:5
singleplot(cov=cov, dim=dim, li=li, plotmethod, dots=dots,
dotnames=dotnames)
# Print(mnames, dots$col, dots$lty)
if (length(x) > 1) legend(x="topright", legend=mnames,
col=dots$col, lty=dots$lty)
} else { ## multivariate
scr <- matrix(split.screen(figs=figs), ncol=dimcov[2], byrow=TRUE)
par(oma=margins)
title(main=dots$main, xlab=dots$xlab, ylab=dots$ylab,
outer=TRUE, cex.main=dots$cex.main)
dots.axis = dots[names(dots) != "type"]
dots.axis$col = dots.axis$col.axis
if (!("axes" %in% dotnames)) dots$axes <- FALSE
for (i in 1:ncol(scr)) {
for (j in 1:nrow(scr)) {
dots$main <-
eval(parse(text=paste("expression(C[", i, j,"])", sep="")))
screen(scr[i,j])
par(mar=c(0,0,2,1))
singleplot(cov = sapply(cov, function(x) x[, i,j]),
dim = dim, li=li, plotmethod=plotmethod, dots=dots,
dotnames = dotnames)
box()
if (i==1) do.call(graphics::axis,
args=c(dots.axis, list(side=1, outer = TRUE, line=1)))
if (j==1) do.call(graphics::axis,
args=c(dots.axis, list(side=2, outer = TRUE, line=1)))
}
}
}
if (graphics$split_screen && graphics$close_screen) {
close.screen(scr)
scr <- NULL
}
return(scr)
}
points.RMmodel <- function(x, ..., type="p")
RFplotModel(x, ...,type=type, plotmethod="plot.xy")
lines.RMmodel <- function(x, ..., type="l")
RFplotModel(x, ...,type=type, plotmethod="plot.xy")
# @FUNCTION-STARP**********************************************************
# @NAME list2RMmodel
# @REQUIRE a list
# @AUTHOR A Malinowski <malinows@math.uni-goettingen.de>
# @DATE 26.09.2011
# @FUNCTION-END************************************************************
list2RMmodel <- function(x) {
if (!is.list(x)) return(x)
name <- x[[1]]
if (!is.character(name)) return(x)
if (name == RM_DECLARE) return(NULL)
len <- length(x)
if (name %in% DOLLAR) return(list2RMmodel(c(x[[len]], x[-c(1, len)])))
# if (name == RM_DISTR[1]){
# x <- x[-1]
# m <- do.call(RM_DISTR[1], args=list())
# m@par.model <- x
# return(m)
# }
if (name==SYMBOL_PLUS) name <- RM_PLUS[1] else
if (name==SYMBOL_MULT) name <- RM_MULT[1] else
if (!(name %in% list2RMmodel_Names)) {
if (!(name %in% list2RMmodel_oldNames))
stop(paste("'", name, "' is not the name of a valid model", sep=""))
}
## hier noch mehr Ausnahmen?
if (len==1) return(eval(parse(text=paste(name, "()", sep=""))))
else {
x <- lapply(x, FUN=list2RMmodel)
if (length(idx <- which("anisoT" == names(x))) == 1){
names(x)[idx] <- "Aniso"
x[[idx]] <- t(x[[idx]])
}
return(do.call(name, args=x[-1]))
}
}
setMethod(f="plot", signature(x=CLASS_CLIST, y="missing"),
function(x, y, ...) RFplotModel(x, ...))
setMethod(f="lines", signature(x=CLASS_CLIST),
function(x, ..., type="l")
RFplotModel(x, ..., type=type, plotmethod="plot.xy"))
setMethod(f="points", signature(x=CLASS_CLIST),
function(x, ..., type="p")
RFplotModel(x, ..., type=type, plotmethod="plot.xy"))
setMethod(f="persp", signature(x=CLASS_CLIST),
function(x, ..., dim=2, zlab="")
RFplotModel(x,...,dim=dim,zlab=zlab,plotmethod="persp"))
setMethod(f="image", signature(x=CLASS_CLIST),
function(x, ..., dim=2) RFplotModel(x,...,dim=dim,plotmethod="image"))
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 list2RMmodel lines.RMmodel points.RMmodel RFplotModel singleplot preparePlotRMmodel rfConvertRMmodel2string print.RMmodelgenerator print.RMmodel print.RM_model print.summary.RMmodel summary.RM_model summary.RMmodel str.RMmodel XresolveRight XresolveLeft Xresolve resolveLeft resolveRight resolve accessReplaceSlotsByName accessSlotsByName
Documented in lines.RMmodel points.RMmodel print.RMmodel print.RMmodelgenerator RFplotModel str.RMmodel
## Authors
## Martin Schlather, schlather@math.uni-mannheim.de
##
##
## Copyright (C) 2015 -- 2017 Alexander Malinowski & Martin Schlather
## Copyright (C) 2017 -- 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.
## accessing CLASS_CLIST and RMmodelgenerator via '['-operator
# e.g. RMwhittle["domain"]
accessSlotsByName <- function(x,i,j,drop=FALSE) {
names <- slotNames(x)
if (!(i %in% names))
stop(paste(i, "is not a valid slot specification"))
return(slot(x, i))
}
accessReplaceSlotsByName <- function(x,i,j,value) {
names <- slotNames(x)
if (!(i %in% names))
stop(paste(i, "dis not a valid slot specification"))
else
slot(x, i) <- value
validObject(x)
return(x)
}
setMethod(f="[", signature = CLASS_CLIST, def = accessSlotsByName)
setMethod(f="[", signature = CLASS_FIT, def = accessSlotsByName)
setMethod(f="[", signature = CLASS_RM, def = accessSlotsByName)
setReplaceMethod(f="[", signature = CLASS_CLIST, accessReplaceSlotsByName)
setReplaceMethod(f="[", signature = CLASS_FIT, accessReplaceSlotsByName)
setReplaceMethod(f="[", signature = CLASS_RM,accessReplaceSlotsByName)
## summing up RMmodels
setMethod('c', signature=c(CLASS_CLIST),
function(x, ..., recursive = FALSE) R.c(x, ...) )
## funktioniert im speziellen Modus nicht, allgemein schon
## warum ist unklar
#setMethod('diag', signature=c(CLASS_CLIST, 'missing', 'missing', 'missing'),
# function(x=1, nrow, ncol, names=TRUE) {
# ## Print("hier"); str(x)
# RMmatrix(x)
# })
resolve <- function(e1, e2, sign) {
## RMmodels only
d <- list()
if (e1@name==sign && (len.e1 <- length(e1@submodels)) < MAXSUB) {
for (i in 1:len.e1) d[[i]] <- e1@submodels[[i]]
} else {
len.e1 <- 1
d[[1]] <- if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
# do.call(SYMBOL_P, list(e1))
else e1
}
d[[len.e1 + 1]] <-
(if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
# do.call(SYMBOL_P, list(e2))
else e2)
if (sign == RM_MULT[1]) {
# print(d)
model <- do.call(sign, d)
} else model <- do.call(sign, d)
return(model)
}
warn.resolve.txt <- "A large vector consists fully of NAs -- the model is probably not correct.\nNote that it is always better to define the covariance model in the first\nsummands and then the trend. Also better use explicitely 'R.c', 'RMcovariate'\nand 'R.const' if the model is more complicated"
resolveRight<- function(e1, e2, sign) {
## left constant
d <- list()
if (e1@name==sign && (len.e1 <- length(e1@submodels)) < MAXSUB) {
for (i in 1:len.e1) d[[i]] <- e1@submodels[[i]]
} else {
len.e1 <- 1
d[[1]] <- (if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
}
d[[len.e1 + 1]] <-
if (is.list(e2)) do.call(R_C, e2)
else if (length(e2)==1) do.call(R_CONST, list(e2))
else if (!all(is.finite(e2))) {
if (all(is.na(e2)) && length(e2)>5) warning(warn.resolve.txt)
do.call(R_C, list(e2))
} else if (sign == RM_PLUS[1]) {
tmpList <- list(RM_COVARIATE)
tmpList[[COVARIATE_C_NAME]] <- e2
tmpList[[COVARIATE_X_NAME]] <- NULL
tmpList[[COVARIATE_ADDNA_NAME]] <- TRUE
do.call(RM_COVARIATE, tmpList)
} else do.call(R_C, list(e2))
## Version brasilienc
## if (length(e2)==1) d[[len.e1 + 1]] <- do.call(R_CONST, list(e2))
## else {
## e <- list(e2)
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[len.e1 + 1]] <- do.call(RM_COVARIATE, e)
## }
model <- do.call(sign, d)
return(model)
}
resolveLeft<- function(e1, e2, sign) {
## right constant
d <- list()
len.e1 <- 1
## Version Brasilien
# if (length(e1)==1) d[[1]] <- do.call(R_CONST, list(e1))
# else {
# e <- list(e1)
# e[[COVARIATE_ADDNA_NAME]] <- TRUE
# d[[1]] <- do.call(RM_COVARIATE, e)
# }
d[[1]] <- if (is.list(e1)) do.call(R_C, e1)
else if (length(e1)==1) do.call(R_CONST, list(e1))
else if (!all(is.finite(e1))) {
if (all(is.na(e1)) && length(e1)>5) warning(warn.resolve.txt)
do.call(R_C, list(e1))
} else if (sign == RM_PLUS[1]) {
tmpList <- list(RM_COVARIATE)
tmpList[[COVARIATE_C_NAME]] <- e1
tmpList[[COVARIATE_X_NAME]] <- NULL
tmpList[[COVARIATE_ADDNA_NAME]] <- TRUE
do.call(RM_COVARIATE, tmpList)
} else do.call(R_C, list(e1))
d[[len.e1 + 1]] <- (if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
##do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(sign, d)
return(model)
}
## summing up RMmodels
setMethod('+', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'factor'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'list'),
function(e1, e2) resolveRight(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('numeric', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('logical', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('data.frame', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('factor', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
setMethod('+', signature=c('character', CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_PLUS[1]))
## multiplying RMmodels
setMethod('*', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('numeric', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('logical', CLASS_CLIST),
function(e1, e2) resolveLeft(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) resolveRight(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) resolveRight(e1, e2, RM_MULT[1]))
setMethod('*', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
setMethod('*', signature=c('character', CLASS_CLIST),
function(e1, e2) resolve(e1, e2, RM_MULT[1]))
Xresolve <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
d[[1]] <-
(if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
d[[len.e1 + 1]] <-
( if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(model, d)
return(model)
}
XresolveLeft <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
if (length(e1)==1) d[[1]] <- do.call(R_CONST, list(e1))
else {
e <- list(e1)
d[[1]] <- do.call(R_CONST, e)
## version brasilien
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[1]] <- do.call(RM_COVARIATE, e)
}
d[[len.e1 + 1]] <- (if (is.character(e2))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e2))
else e2)
model <- do.call(model, d)
return(model)
}
XresolveRight <- function(e1, e2, model) {
d <- list()
len.e1 <- 1
d[[1]] <- (if (is.character(e1))
stop("characters cannot be combined with 'RMmodels'")
#do.call(SYMBOL_P, list(e1))
else e1)
if (length(e2)==1) d[[len.e1 + 1]] <- do.call(R_CONST, list(e2))
else {
e <- list(e2)
d[[len.e1 + 1]] <- do.call(R_CONST, e)
## version brasilien
## e[[COVARIATE_ADDNA_NAME]] <- TRUE
## d[[len.e1 + 1]] <- do.call(RM_COVARIATE, e)
}
model <- do.call(model, d)
return(model)
}
## substracting RMmodels
setMethod('-', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
setMethod('-', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.minus"))
setMethod('-', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.minus"))
setMethod('-', signature=c(CLASS_CLIST, 'character'),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
setMethod('-', signature=c('character', CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.minus"))
## dividing up RMmodels
setMethod('/', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.div"))
setMethod('/', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.div"))
setMethod('/', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.div"))
setMethod('/', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.div"))
setMethod('/', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.div"))
setMethod('/', signature=c('RMmodel', 'character'),
function(e1, e2) Xresolve(e1, e2, "R.div"))
setMethod('/', signature=c('character', 'RMmodel'),
function(e1, e2) Xresolve(e1, e2, "R.div"))
## powering up RMmodels
setMethod('^', signature=c(CLASS_CLIST, CLASS_CLIST),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
setMethod('^', signature=c('numeric', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.pow"))
setMethod('^', signature=c('logical', CLASS_CLIST),
function(e1, e2) XresolveLeft(e1, e2, "R.pow"))
setMethod('^', signature=c(CLASS_CLIST, 'numeric'),
function(e1, e2) XresolveRight(e1, e2, "R.pow"))
setMethod('^', signature=c(CLASS_CLIST, 'logical'),
function(e1, e2) XresolveRight(e1, e2, "R.pow"))
setMethod('^', signature=c('RMmodel', 'character'),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
setMethod('^', signature=c('character', 'RMmodel'),
function(e1, e2) Xresolve(e1, e2, "R.pow"))
## str, print and show
## str.RMmodel is basically copied from str.default, but where
## those slots of 'par.general' are excluded from being printed
## for which the value is 'RFdefault', i.e. for which there is no
## explicit value given
str.RMmodel <-
function(object, max.level = NA, vec.len = strO$vec.len,
digits.d = strO$digits.d,
nchar.max = 128, give.attr = TRUE, give.head = TRUE,
give.length = give.head,
width = getOption("width"), nest.lev = 0,
indent.str = paste(rep.int(" ",
max(0, nest.lev + 1)), collapse = ".."),
comp.str = "$ ", no.list = FALSE, envir = baseenv(),
strict.width = strO$strict.width,
drop.deparse.attr = strO$drop.deparse.attr,
formatNum = strO$formatNum, list.len = 99, ...)
{
oDefs <- c("strict.width", "vec.len", "digits.d", "drop.deparse.attr",
"formatNum")
strO <- getOption("str")
if (!is.list(strO)) {
warning("invalid options('str') -- using defaults instead")
strO <- strOptions()
}
else {
if (!all(names(strO) %in% oDefs))
warning("invalid components in options('str'): ",
paste(setdiff(names(strO), oDefs), collapse = ", "))
strO <- modifyList(strOptions(), strO)
}
strict.width <- match.arg(strict.width, choices = c("no", "cut", "wrap"))
if (strict.width != "no") {
ss <- capture.output(str(object, max.level = max.level, #
vec.len = vec.len, digits.d = digits.d,
drop.deparse.attr = drop.deparse.attr,
nchar.max = nchar.max,
give.attr = give.attr,
give.head = give.head,
give.length = give.length,
width = width, nest.lev = nest.lev,
indent.str = indent.str,
comp.str = comp.str,
no.list = no.list || is.data.frame(object),
envir = envir, strict.width = "no", ...))
if (strict.width == "wrap") {
nind <- nchar(indent.str) + 2
ss <- strwrap(ss, width = width, exdent = nind)
}
if (any(iLong <- nchar(ss) > width))
ss[iLong] <- sub(sprintf("^(.{1,%d}).*", width - 2), "\\1..", ss[iLong])
cat(ss, sep = "\n")
return(invisible())
}
oo <- options(digits = digits.d)
on.exit(options(oo))
le <- length(object)
P0 <- function(...) paste(..., sep = "")
`%w/o%` <- function(x, y) x[is.na(match(x, y))]
nfS <- names(fStr <- formals())
strSub <- function(obj, ...) {
nf <- nfS %w/o% c("object", "give.length", "comp.str",
"no.list", names(match.call())[-(1:2)], "...")
aList <- as.list(fStr)[nf]
aList[] <- lapply(nf, function(n) eval(as.name(n)))
if ("par.general" %in% names(obj)){
is.RFdefault <-
unlist(lapply(obj$par.general,
FUN=function(x){
!is(x, CLASS_CLIST) && !is.na(x) && x==RM_DEFAULT
}))
obj$par.general[is.RFdefault] <- NULL
if (all(is.RFdefault)) obj$par.general <- list()
}
do.call(utils::str, c(list(object = obj), aList, list(...)),
quote = TRUE)
}
v.len <- vec.len
std.attr <- "names"
cl <- if ((S4 <- isS4(object)))
class(object)
else oldClass(object)
has.class <- S4 || !is.null(cl)
mod <- ""
char.like <- FALSE
if (give.attr)
a <- attributes(object)
if (is.null(object))
cat(" NULL\n")
else if (S4) {
a <- sapply(methods::.slotNames(object), methods::slot,
object = object, simplify = FALSE)
cat("Formal class", " '", paste(cl, collapse = "', '"),
"' [package \"", attr(cl, "package"), "\"] with ",
length(a), " slots\n", sep = "")
strSub(a, comp.str = "@ ", no.list = TRUE,
give.length = give.length,
indent.str = paste(indent.str, ".."),
nest.lev = nest.lev + 1)
return(invisible())
}
}
summary.RMmodel <- function(object, max.level=5, ...)
summary(PrepareModel2(object, ...), max.level=max.level)
summary.RM_model <- function(object, ...) {
class(object) <- "summary.RMmodel"
object
}
print.summary.RMmodel <- function(x, max.level=5, ...) {
str(x, no.list=TRUE, max.level = max.level, give.attr=FALSE) #
invisible(x)
}
print.RM_model <- function(x, max.level=5,...) {
print.summary.RMmodel(summary.RM_model(x, max.level=max.level,...),
max.level=max.level)#
}
print.RMmodel <- function(x, max.level=5,...) {
print.summary.RMmodel(summary.RMmodel(x, max.level=max.level, ...),
max.level=max.level)#
}
setMethod(f="show", signature=CLASS_CLIST,
definition=function(object) print.RMmodel(object))#
print.RMmodelgenerator <- function(x, ...) {
cat("*** object of Class '", CLASS_RM, "' ***\n", sep="")
str(args(x@.Data)) ## ok
cat(" type : \t", paste(x@type, collapse=", "), "\n")
cat(" domain : \t", paste(x@domain, collapse=", "), "\n")
cat(" isotropy : \t", paste(x@isotropy, collapse=", "), "\n")
cat(" monotoniciy :\t", paste(x@monotone, collapse=", "), "\n")
cat(" multivariate:\t",
if (x@vdim >= 0) x@vdim
else if (x@vdim == PARAM_DEP) "parameter dependent"
else if (x@vdim == PREVMODEL_DEP) "depends on calling model"
else if (x@vdim == SUBMODEL_DEP) "submodel dependent"
else "specification unclear -- please contact maintainer",
"\n")
cat(" max. dimen. :\t",
if (x@maxdim >= 0) x@maxdim
else if (x@maxdim == PARAM_DEP) "parameter dependent"
else if (x@maxdim == PREVMODEL_DEP) "depends on calling model"
else if (x@maxdim == SUBMODEL_DEP) "submodel dependent"
else "specification unclear -- please contact maintainer",
"\n")
cat(" finite range:\t", x@finiterange, "\n")
cat(" operator : \t", x@operator, "\n")
cat(" simple fctn :\t", x@simpleArguments, "\n")
}
setMethod("show", signature=CLASS_RM,
definition=function(object) print.RMmodelgenerator(object))
rfConvertRMmodel2string <- function(model){
if (!is(model, class2=CLASS_CLIST))
stop("model must be of class '", CLASS_CLIST, "'")
par <- c(model@par.model, model@par.general)
idx.random <- unlist(lapply(par, FUN=isRMmodel))
if (is.null(idx.random)){
param.string <- ""
param.random.string <- ""
} else {
idx.default <- par[!idx.random] == RM_DEFAULT
param.string <- paste(names(par[!idx.random][!idx.default]),
par[!idx.random][!idx.default],
sep="=", collapse=", ")
#if (sum(idx.random) > 0){
string.vector <- lapply(par[idx.random], FUN=rfConvertRMmodel2string)
param.random.string <- paste(names(par[idx.random]), string.vector,
sep="=", collapse=", ")
}
if (length(model@submodels) > 0){
string.vector <- lapply(model@submodels, FUN=rfConvertRMmodel2string)
submodel.string <- paste(names(model@submodels), string.vector,
sep="=", collapse=", ")
if (!(nchar(param.string)==0))
submodel.string <- paste(submodel.string, ", ", sep="")
}
else submodel.string <- ""
string <- paste(model@name, "(", submodel.string, param.random.string,
param.string, ")", sep="")
return(string)
}
## Plot
preparePlotRMmodel <- function(x, xlim, ylim, n.points, dim, fct.type,
MARGIN, fixed.MARGIN, ...){
types <- c("Cov", "Variogram", "Fctn")
## types <- "Fctn"; print("remove")
verballist <- paste("'", types, "'", sep="", collapse="")
if (!missing(fct.type) && length(fct.type) > 0) {
if (!(fct.type %in% types))
stop("fct.type must be NULL or of the types ", verballist)
types <- fct.type
}
all.fct.types <- character(length(x))
all.vdim <- numeric(length(x))
for (i in 1:length(x)) {
fct.type <- types
m <- list("", PrepareModel2(x[[i]]), ...)
while (length(fct.type) > 0 &&
{ m[[1]] <- fct.type[1];
!is.numeric(vdim <- try( InitModel(MODEL_AUX, m, dim),
silent=TRUE))
## Print(CCC)
})
fct.type <- fct.type[-1]
if (!is.numeric(vdim)) {
## Print(vdim, model)
## stop("'vdim' is not numeric")
stop(attr(vdim, "condition")$message)
}
if (vdim[1] != vdim[2]) stop("only simple models can be plotted")
all.vdim[i] <- vdim[1]
all.fct.types[i] <- fct.type[1]
}
if (!all(all.vdim == all.vdim[1]))
stop("models have different multivariability")
# fctcall.vec <- c("Cov", "Variogram")
#covinfo <- RFgetModelInfo(register=MODEL_AUX, level=3, spConform=TRUE)
### Print((covinfo))
# Print(covinfo$domown, TRANS_INV , covinfo$type, isPosDef(covinfo$type),
# is.null(fct.type), fct.type,"Variogram") ; xxx
if (is.null(xlim)) {
xlim <- if (dim > 1 || all.vdim[1] > 1) c(-1, 1) * 1.75 else c(0, 1.75)
}
if (is.null(ylim) && dim > 1) ylim <- xlim
distance <- seq(xlim[1], xlim[2], length=n.points)
if (prod(xlim) <= 0)
distance <- sort(c(if (!any(distance==0)) 0, 1e-5, distance))
if (dim > 1) {
distanceY <- seq(ylim[1], ylim[2], length=n.points)
if (prod(ylim) < 0 & !(any(distanceY==0)))
distanceY <- sort(c(0, distanceY))
}
# Print(covinfo)
# if(covinfo$domown != TRANS_INV)
# stop("method only implemented for models that are not kernels")
if (all(all.fct.types[1] == all.fct.types)) {
switch(all.fct.types[1],
"Cov" = {
main <-"Covariance function"
ylab <- "C(distance)"
},
"Variogram" = {
main <- "Variogram"
ylab <- expression(gamma(distance))
},
"Fctn" = {
main<- ""
ylab <- "f(distance)"
},
stop("method only implemented for ", verballist)
)
} else {
main <- ""
ylab <- "f(distance)"
}
if (length(x) == 1) {
for.what <- rfConvertRMmodel2string(x[[1]])
if (nchar(for.what) > 20) for.what <- strsplit(for.what,"\\(")[[1]][1]
} else {
for.what <- "various models"
}
# main <- paste(main, " plot for ", for.what, "\n", sep="")
main <- paste("plot for ", for.what, "\n", sep="")
if (dim >= 3)
main <- paste(sep="", main, "; component", if (dim>3) "s", " ",
paste((1:dim)[-MARGIN], collapse=", "),
" fixed to the value", if (dim>3) "s", " ",
paste(format(fixed.MARGIN, digits=4), collapse=", "))
return(list(main=main, fctcall=all.fct.types, ylab=ylab, distance=distance,
distanceY = if (dim > 1) distanceY, xlim=xlim, ylim=ylim))
}
singleplot <- function(cov, dim, li, plotmethod, dots, dotnames) {
if (dim==1) {
D <- li$distance
iszero <- D == 0
if (plotmethod == "matplot") {
plotpoint <- any(iszero) && diff(range(dots$ylim)) * 1e-3 <
diff(range(cov)) - diff(range(cov[!iszero]))
if (plotpoint) D[iszero] <- NA
} else plotpoint <- FALSE
liXY <-
if (plotmethod=="plot.xy") list(xy = xy.coords(x=D, y=cov)) ## auch D ?
else list(x=D, y=cov)
## Print(plotmethod, args=c(dots, liXY))
do.call(plotmethod, args=c(dots, liXY))
if (plotpoint) {
for (i in 1:ncol(cov))
points(0, cov[iszero, i], pch=19 + i, col = dots$col[i])
}
} else {
if (!("zlim" %in% dotnames)) dots$zlim <- range(unlist(cov), finite=TRUE)
addgiven <- "add" %in% dotnames
local.dots <- dots
local.dots$col <- NULL
local.dots$lty <- NULL
is.contour <- is.character(plotmethod) && plotmethod == "contour"
if (!is.contour) {
if (ncol(cov) > 1)
stop("several models can be plotted at once only with 'contour'")
col <- default.image.par(dots$zlim, NULL)$data$default.col
}
for (i in 1:ncol(cov)) {
if (!addgiven && is.contour) local.dots$add <- i > 1
do.call(plotmethod,
args=c(list(x=li$distance, y=li$distanceY,
col=if (is.contour) dots$col[i] else col,
lty = dots$lty[i],
z=matrix(cov[, i], nrow=length(li$distance))), local.dots))
}
}
}
RFplotModel <- function(x, y, dim=1,
n.points=
if (dim==1 || is.contour) 200 else 100,
fct.type=NULL,
MARGIN, fixed.MARGIN,
maxchar=15, ...,
plotmethod=if (dim==1) "matplot" else "contour") {
is.contour <- is.character(plotmethod) && plotmethod == "contour"
RFopt <- RFoptions()
if (ex.red <- RFopt$internal$examples_reduced)
n.points <- as.integer(min(n.points, ex.red - 2))
stopifnot(length(dim)==1)
if (!(dim %in% 1:10))
stop("only 'dim==1', 'dim==2' and 'dim==3' are allowed")
if (dim==3)
if (missing(MARGIN) || missing(fixed.MARGIN))
stop("'MARGIN' and 'fixed.MARGIN' must be given if dim >=3")
if ((!missing(MARGIN)) || (!missing(fixed.MARGIN))) {
stopifnot((!missing(MARGIN)) && (!missing(fixed.MARGIN)))
if (dim < 3)
stop("'MARGIN' and 'fixed.MARGIN' should only be given for dim>=3")
stopifnot(is.numeric(MARGIN) && length(MARGIN)==2)
stopifnot(is.numeric(fixed.MARGIN) && (length(fixed.MARGIN) == dim - 2))
}
dots <- list(...)
dotnames <- names(dots)
models <- substr(dotnames, 1, 5) == "model"
x <- c(list(x), dots[models])
mnames <- c("", substr(dotnames[models], 6, 100))
idx <- substr(mnames, 1, 1) == "."
mnames[idx] <- substr(mnames[idx], 2, 1000)
for (i in which(!idx)) {
mnames[i] <- rfConvertRMmodel2string(x[[i]])
nmn <- nchar(mnames[i]) - 1
if (substr(mnames[i], nmn, nmn) == "(") {
mnames[i] <- substr(mnames[i], 1, nmn - 1)
}
msplit <- strsplit(mnames[i], "RM")[[1]]
if (length(msplit) == 2 && msplit[1]=="") mnames[i] <- msplit[2]
}
mnames <- substr(mnames, 1, maxchar)
dots <- mergeWithGlobal(dots[!models])
dotnames <- names(dots)
if (!("type" %in% dotnames)) dots$type <- "l"
li <- preparePlotRMmodel(x=x, xlim=dots$xlim, ylim=dots$ylim,
n.points=n.points, dim=dim,
fct.type=fct.type,
MARGIN=MARGIN, fixed.MARGIN=fixed.MARGIN)
dots$xlim <- li$xlim
if (!is.null(li$ylim)) dots$ylim <- li$ylim
if (!("main" %in% dotnames)) dots$main <- li$main
if (!("cex" %in% dotnames)) dots$cex <- 1
if (!("cex.main" %in% dotnames)) dots$cex.main <- 1.3 * dots$cex
if (!("cex.axis" %in% dotnames)) dots$cex.axis <- 1.0 * dots$cex
if (!("cex.lab" %in% dotnames)) dots$cex.lab <- 1.0 * dots$cex
if (!("col" %in% dotnames)) dots$col <- rep(1:7, length.out=length(x))
cov <- list()
if (dim==1) {
for (i in 1:length(x))
cov[[i]] <- rfeval(x=li$distance, model=x[[i]], fctcall=li$fctcall[i])
#print(cov, li$distance)
lab <- xylabs("distance", li$ylab)
## strokorb monotone ist z.B. nicht ueberall finite:
if (!("ylim" %in% dotnames)) dots$ylim <- range(0, unlist(cov), finite=TRUE)
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
} else {
lab <- xylabs("", "")
if (!("xlab" %in% dotnames)) dots$xlab <- lab$x
if (!("ylab" %in% dotnames)) dots$ylab <- lab$y
dots$type <- NULL
if (dim==2) {
di <- as.matrix(expand.grid(li$distance, li$distanceY))
for (i in 1:length(x)) {
cov[[i]] <- rfeval(x=di, model=x[[i]], fctcall=li$fctcall[i])
}
} else if (dim>=3) {
m1 <- expand.grid(li$distance, li$distanceY)
m2 <- matrix(NA, ncol=dim, nrow=nrow(m1))
m2[,MARGIN] <- as.matrix(m1)
m2[,-MARGIN] <- rep(fixed.MARGIN, each=nrow(m1))
for (i in 1:length(x))
cov[[i]] <- rfeval(x=m2, model=x[[i]], fctcall=li$fctcall[i])
} else stop("this error should never appear")
}
if ((is.null(dots$xlab) || dots$xlab=="") &&
(is.null(dots$ylab) || dots$ylab=="")) {
margins <- c(3, 3, if (dots$main=="") 0 else 2, 0) + 0.2
} else {
margins <- c(5, 5, if (dots$main=="") 0 else 2, 0) + 0.2
}
dimcov <- dim(cov[[1]])
graphics <- RFopt$graphics
if (plotmethod != "plot.xy") { ### points and lines !!
if (is.null(dimcov)) { ## i.e. vdim == 1
ArrangeDevice(graphics, c(1,1))
} else {
figs <- dimcov[2:3]
ArrangeDevice(graphics, figs)
}
}
scr <- NULL
if (is.null(dimcov)) { ## i.e. vdim == 1
cov <- sapply(cov, function(x) x)
if (!("lty" %in% dotnames)) dots$lty <- 1:5
singleplot(cov=cov, dim=dim, li=li, plotmethod, dots=dots,
dotnames=dotnames)
# Print(mnames, dots$col, dots$lty)
if (length(x) > 1) legend(x="topright", legend=mnames,
col=dots$col, lty=dots$lty)
} else { ## multivariate
scr <- matrix(split.screen(figs=figs), ncol=dimcov[2], byrow=TRUE)
par(oma=margins)
title(main=dots$main, xlab=dots$xlab, ylab=dots$ylab,
outer=TRUE, cex.main=dots$cex.main)
dots.axis = dots[names(dots) != "type"]
dots.axis$col = dots.axis$col.axis
if (!("axes" %in% dotnames)) dots$axes <- FALSE
for (i in 1:ncol(scr)) {
for (j in 1:nrow(scr)) {
dots$main <-
eval(parse(text=paste("expression(C[", i, j,"])", sep="")))
screen(scr[i,j])
par(mar=c(0,0,2,1))
singleplot(cov = sapply(cov, function(x) x[, i,j]),
dim = dim, li=li, plotmethod=plotmethod, dots=dots,
dotnames = dotnames)
box()
if (i==1) do.call(graphics::axis,
args=c(dots.axis, list(side=1, outer = TRUE, line=1)))
if (j==1) do.call(graphics::axis,
args=c(dots.axis, list(side=2, outer = TRUE, line=1)))
}
}
}
if (graphics$split_screen && graphics$close_screen) {
close.screen(scr)
scr <- NULL
}
return(scr)
}
points.RMmodel <- function(x, ..., type="p")
RFplotModel(x, ...,type=type, plotmethod="plot.xy")
lines.RMmodel <- function(x, ..., type="l")
RFplotModel(x, ...,type=type, plotmethod="plot.xy")
# @FUNCTION-STARP**********************************************************
# @NAME list2RMmodel
# @REQUIRE a list
# @AUTHOR A Malinowski <malinows@math.uni-goettingen.de>
# @DATE 26.09.2011
# @FUNCTION-END************************************************************
list2RMmodel <- function(x) {
if (!is.list(x)) return(x)
name <- x[[1]]
if (!is.character(name)) return(x)
if (name == RM_DECLARE) return(NULL)
len <- length(x)
if (name %in% DOLLAR) return(list2RMmodel(c(x[[len]], x[-c(1, len)])))
# if (name == RM_DISTR[1]){
# x <- x[-1]
# m <- do.call(RM_DISTR[1], args=list())
# m@par.model <- x
# return(m)
# }
if (name==SYMBOL_PLUS) name <- RM_PLUS[1] else
if (name==SYMBOL_MULT) name <- RM_MULT[1] else
if (!(name %in% list2RMmodel_Names)) {
if (!(name %in% list2RMmodel_oldNames))
stop(paste("'", name, "' is not the name of a valid model", sep=""))
}
## hier noch mehr Ausnahmen?
if (len==1) return(eval(parse(text=paste(name, "()", sep=""))))
else {
x <- lapply(x, FUN=list2RMmodel)
if (length(idx <- which("anisoT" == names(x))) == 1){
names(x)[idx] <- "Aniso"
x[[idx]] <- t(x[[idx]])
}
return(do.call(name, args=x[-1]))
}
}
setMethod(f="plot", signature(x=CLASS_CLIST, y="missing"),
function(x, y, ...) RFplotModel(x, ...))
setMethod(f="lines", signature(x=CLASS_CLIST),
function(x, ..., type="l")
RFplotModel(x, ..., type=type, plotmethod="plot.xy"))
setMethod(f="points", signature(x=CLASS_CLIST),
function(x, ..., type="p")
RFplotModel(x, ..., type=type, plotmethod="plot.xy"))
setMethod(f="persp", signature(x=CLASS_CLIST),
function(x, ..., dim=2, zlab="")
RFplotModel(x,...,dim=dim,zlab=zlab,plotmethod="persp"))
setMethod(f="image", signature(x=CLASS_CLIST),
function(x, ..., dim=2) RFplotModel(x,...,dim=dim,plotmethod="image"))
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.