https://github.com/cran/RandomFields
Tip revision: 41d603eb8a5f4bfe82c56acee957c79e7500bfd4 authored by Martin Schlather on 18 January 2022, 18:12:52 UTC
version 3.3.14
version 3.3.14
Tip revision: 41d603e
Class.R
## Authors
## Martin Schlather, schlather@math.uni-mannheim.de
##
##
## Copyright (C) 2012 -- 2015 Alexander Malinowski & Martin Schlather
## Copyright (C) 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.
##########################################################################
## classes for 2- and higher-dimensional data objects, based on ##########
## Spatial classes from 'sp'-package ##########
setClass("RFspatialGridDataFrame", contains ="SpatialGridDataFrame",
representation(.RFparams="list") )
setValidity("RFspatialGridDataFrame",
function(object) {
return(check.validity.n.vdim(object))
})
setClass("RFspatialPointsDataFrame", contains ="SpatialPointsDataFrame",
representation(.RFparams="list") )
setValidity("RFspatialPointsDataFrame",
function(object) {
return(check.validity.n.vdim(object))
})
## classes for 1-dimensional data objects ################################
setClass("RFgridDataFrame",
representation(data="data.frame", grid="GridTopology",
.RFparams="list"))
setValidity("RFgridDataFrame",
function(object) {
if (length(object@grid@cells.dim) > 1)
return("this class is only for 1-dimensional coordinates")
if (nrow(object@data) != object@grid@cells.dim)
return("data must have the same length as the grid length")
return(check.validity.n.vdim(object))
})
setClass("RFpointsDataFrame",
representation(data="data.frame", coords="matrix",
.RFparams="list"),
prototype(data=data.frame(NULL), coords=NULL, .RFparams=list()))
setValidity("RFpointsDataFrame",
function(object) {
if (nrow(object@data) != length(object@coords))
return("data and coords must have the same length")
if (ncol(object@coords)!=1)
return("coords must have exactly 1 column, otherwise use class 'RFspatialPointsDataFrame'")
return(check.validity.n.vdim(object))
})
setClassUnion("RFspatialDataFrame",
c("RFspatialGridDataFrame", "RFspatialPointsDataFrame"))
setClassUnion("RFdataFrame", c("RFgridDataFrame", "RFpointsDataFrame"))
setClassUnion("RFsp", c("RFspatialGridDataFrame", "RFspatialPointsDataFrame",
"RFgridDataFrame", "RFpointsDataFrame"))
check.validity.n.vdim <- function(object) {
if (!all(c("n", "vdim") %in% names(object@.RFparams)))
return("slot '.RFparams' must contain 'n' and 'vdim'")
var.given <- !is.null(object@.RFparams$has.variance) &&
object@.RFparams$has.variance
nc <- (object@.RFparams$n + var.given) * object@.RFparams$vdim
if (nc != ncol(object@data)) {
stop("number of data at each location (=", ncol(object@data),
") does not match the expected ones (=", nc,
").\n The latter is based on the information or assumption that there are\n ",
object@.RFparams$n, " repetition(s) of ",
object@.RFparams$vdim, " variable(s)",
if (var.given) " and the variances",
" given.",
if (object@.RFparams$n * object@.RFparams$vdim == 1) "\nEither wrong parameters have been given for 'RFspatialGridDataFrame' or 'RFspatialPointsDataFrame' or an explicite transformation of the data from 'sp' objects to 'RFsp' objects has not been performed with 'sp2RF'.")
}
return(TRUE)
}
## definition of class CLASS_CLIST
setClass(CLASS_CLIST,
representation(
# call='RMexp(var=1, sclae=1, Aniso=id, proj=id)
call = "language",
# name='RMexp'
name = "character",
# submodels=NULL, submodels=list(RMmodel1, RMmodel2)
submodels = "list",
# model specific parameter
par.model = "list",
# var=1, scale=1, Aniso=id, proj=id
par.general = "list"
)
)
## rules for validity checking of CLASS_CLIST objects
isModel <- function(model) return(is.list(model) && is.character(model[[1]]) )
isRMmodel <- function(x) is(x, class2=CLASS_CLIST)
setValidity(CLASS_CLIST,
function(object){
isNUMorDEFAULT <- function(x) {
# Print("class.R", x, RM_DEFAULT)
(is.numeric(x) || is(x, "function") || is(x, "call") ||
is.environment(x) || is.character(x) ||
(length(x) ==1 && x==RM_DEFAULT) || is.logical(x) ||
is.matrix(x) || is.list(x))
}
isRMmodelorNUMorDEFAULT <- function(x)
isRMmodel(x) || isNUMorDEFAULT(x)
if (length(object@submodels) > 0)
if (!all(unlist(lapply(object@submodels, FUN = isRMmodel))))
return(paste("submodels must be of class '", CLASS_CLIST, "'",
sep=""))
passed.params <- c(object@par.model, object@par.general)
if (length(passed.params) > 0) {
if (!all(unlist(lapply(passed.params,
FUN = isRMmodelorNUMorDEFAULT)) ))
return("all parameters must be of class numeric or logical or RMmodel")
}
if(!is.null(object@par.general$var) &&
!isRMmodel(object@par.general$var)) {
if (length(object@par.general$var) > 1) return("not scalar")
if (!is.na(object@par.general$var) &&
(object@par.general$var!=RM_DEFAULT)){
if (object@par.general$var < 0)
return("negative variance")
}
}
if(!is.null(object@par.general$scale) &&
!isRMmodel(object@par.general$scale)) {
if (length(object@par.general$scale) > 1) return("not scalar")
if (!is.na(object@par.general$scale) &&
object@par.general$scale!=RM_DEFAULT)
if(object@par.general$scale <= 0)
return("non-positive scale")
}
if(!is.null(object@par.general$Aniso) &&
!isRMmodel(object@par.general$Aniso) &&
!all(object@par.general$Aniso==RM_DEFAULT) &&
length(object@par.general$Aniso) > 1)
if(!is.matrix(object@par.general$Aniso))
return("'Aniso' must be a matrix")
if(!is.null(object@par.general$proj) &&
# !isRMmodel(object@par.general$proj) &&
# !is.na(object@par.general$proj) &&
!all(object@par.general$proj==RM_DEFAULT)){
if(!is.vector(object@par.general$proj) ||
any(is.na(object@par.general$proj)) ||
any(object@par.general$proj == 0) ||
any(object@par.general$proj < -2) ||
any(object@par.general$proj !=
as.integer(object@par.general$proj))
)
return("proj must be a vector of non-negative integers")
}
return(TRUE)
})
## definition of class CLASS_RM ################################
setClass(CLASS_RM, contains ="function",
representation(
type = "character",
domain = "character",
isotropy = "character",
operator = "logical",
monotone = "character",
finiterange = "logical",
maxdim = "numeric", # max possible dimension
simpleArguments = "logical",
vdim = "numeric" # ??
)
)
## definition of class 'RMmodelFit'
setClass(CLASS_FIT, contains=CLASS_CLIST,
representation(
formel = "ANY",
likelihood = "numeric",
variab = "matrix",
param = "matrix",
globalvariance = "ANY",
covariat = "ANY",
hessian = "ANY",
AIC = "numeric",
AICc = "numeric",
BIC = "numeric",
residuals = "ANY"
)
)
## definition of class 'RFempVariog'
setClass("RFempVariog",
representation(centers = "ANY",
empirical = "ANY",
var = "ANY",
sd = "ANY",
n.bin = "ANY",
phi.centers = "ANY",
theta.centers = "ANY",
T = "ANY",
vdim = "ANY",
coordunits = "character",
varunits = "character",
call = "ANY",
method = "ANY"
)
)
## rules for validity checking of 'RFempVariog' objects
setValidity("RFempVariog",
function(object){
if(!(is.null(object@call)) && !(is(object@call, "language")))
return("slot 'call' must be NULL or of class 'language'")
return(TRUE)
})
## definition of class 'RFfit'
setClass("RFfit",
representation(Z = "list",
ev="RFempVariog",
table = "data.frame",
n.variab = "integer",
n.param = "integer",
n.covariates = "integer",
lowerbounds = CLASS_CLIST,
upperbounds = CLASS_CLIST,
transform = "list",
#vario = "character",
coordunits = "character",
varunits = "character",
number.of.data = "integer",
modelinfo = "data.frame",
number.of.parameters = "integer",
p.proj = "integer",
v.proj = "integer",
x.proj = "ANY", ## integer or logical
fixed = "ANY",
true.tsdim = "integer",
true.vdim = "integer",
report = "character",
submodels = "ANY",
autostart = CLASS_FIT,
users.guess = CLASS_FIT, # Martin: 2.4.: eingefuegt
self = CLASS_FIT,
plain = CLASS_FIT,
sqrt.nr = CLASS_FIT,
sd.inv = CLASS_FIT,
internal1 = CLASS_FIT,
internal2 = CLASS_FIT,
internal3 = CLASS_FIT,
ml = CLASS_FIT
#ml.residuals = "ANY" # matrix or RFsp
)
)
## generic S4 method for 'plot'
setGeneric("plot")