https://github.com/cran/RandomFields
Tip revision: 683e381531c37e8e7224edd899422f119d926418 authored by Martin Schlather on 21 January 2014, 00:00:00 UTC
version 3.0.10
version 3.0.10
Tip revision: 683e381
getNset.R
RFoptions <- function(..., no.readonly=TRUE) {
## on.exit(.C("RelaxUnknownRFoption", FALSE))
## .C("RelaxUnknownRFoption", TRUE)
# Print(list(...))
opt <- .External("RFoptions", ...)
if (length(opt)!=0) {
class(opt) <- "RFopt"
if (!no.readonly) {
assign(".p", GetrfParameters(FALSE))
opt$readonly <- list(covmaxchar=.p$covmaxchar,
covnr=.p$covnr,
distrmaxchar=.p$distrmaxchar,
distrnr=.p$distrnr,
maxdim=.p$maxdim,
maxmodels=.p$maxmodels,
methodmaxchar=.p$methodmaxchar,
methodnr=.p$methodnr
)
}
}
if (is.null(opt)) invisible(opt) else opt
}
internal.rfoptions <- function(..., REGISTER=FALSE, COVREGISTER=as.integer(NA),
RELAX=FALSE){
RFopt <- list()
RFopt[[1]] <- .External("RFoptions")
if (is.logical(REGISTER)) {
REGISTER <- if (REGISTER) RFopt[[1]]$general$register else as.integer(NA)
}
RFopt[[1]]$general$storing <-
c(RFopt[[1]]$general$storing, REGISTER, COVREGISTER)
l <- list(...)
# Print("in", l)
if (length(l) > 0) {
storing <- (substr(names(l), 1, 3) == "sto" |
substr(names(l), 1, 9) == "general.sto")
if (any(storing)) last <- rev(which(storing))[1]
if (any(storing) && !l[[last]]) {
for (p in which(storing)) l[[p]] <- c(FALSE, REGISTER, COVREGISTER)
}
# Print("pass", l)
on.exit(.C("RelaxUnknownRFoption", FALSE))
.C("RelaxUnknownRFoption", RELAX)
.External("RFoptions", LIST=l)
# Print("final", l)
RFopt[[2]] <- .External("RFoptions")
# Print("end", RFopt)
} else {
RFopt[[2]] <- RFopt[[1]]
}
return(RFopt)
}
RFgetModelNames <- function(type = ZF_TYPE, domain = ZF_DOMAIN,
isotropy = ZF_ISOTROPY, operator = c(TRUE, FALSE),
normalmix = c(TRUE, FALSE),
finiterange = c(TRUE, FALSE),
valid.in.dim = c(1, Inf),
vdim = c(1, 5),
group.by=NULL,
internal,
newnames
){ #, .internal=FALSE) {
if (hasArg(internal)) {
return(PrintModelList(operators=operator, internal = internal,
newstyle=missing(newnames) || newnames))
}
if (!missing(newnames) && !newnames) {
if (hasArg(type) || hasArg(domain) || hasArg(isotropy) || hasArg(operator)
|| hasArg(normalmix) || hasArg(finiterange) || hasArg(valid.in.dim)
|| hasArg(vdim) || hasArg(group.by))
stop("use 'newnames=FALSE' without further parameters or in combination with 'internal'")
return (.Call("GetAllModelNames", PACKAGE="RandomFields"))
}
if (!(length(valid.in.dim) %in% 1:2)) stop("'valid.in.dim' has wrong size.")
if (length(valid.in.dim) == 1) valid.in.dim <- c(valid.in.dim, Inf)
if (!(length(vdim) %in% 1:2)) stop("'vdim' has wrong size.")
if (length(vdim) == 1) vdim <- rep(vdim, 2)
debug <- !TRUE
if (group <- !is.null(group.by)) {
names <- c("type", "domain", "isotropy", "operator",
"normalmix", "finiterange", "valid.in.dim", "vdim")
idx <- pmatch(group.by[1], names)
if (is.na(idx))
stop("'group.by' can be equal to '", paste(names, collapse="', '"), "'")
FUN <- function(string){
args <- list(type=type, domain=domain, isotropy=isotropy,
operator=operator, normalmix=normalmix,
finiterange=finiterange, valid.in.dim=valid.in.dim,
vdim=vdim,
if (group && length(group.by) > 1) group.by=group.by[-1])
args[[idx]] <- string
do.call("RFgetModelNames", args)
}
li <- sapply(get(group.by[1]), FUN=FUN)
#if (is.null(names(li))) names(li) <- as.character(possible.values)
length <- unlist(lapply(li, FUN=length))
li <- li[length>0]
return(li)
} # matches if (hasArg(group.by)) {
if (any(is.na(pmatch(type, ZF_TYPE))))
stop(paste("'", type, "'", " is not a valid category", sep=""))
if (any(is.na(pmatch(domain, ZF_DOMAIN))))
stop(paste("'", domain, "'", " is not a valid category", sep=""))
if (any(is.na(pmatch(isotropy, ZF_ISOTROPY))))
stop(paste("'", isotropy, "'", " is not a valid category", sep=""))
envir <- as.environment("package:RandomFields")
ls.RFmg <- ls(envir=envir)
idx <- logical(len <- length(ls.RFmg))
for (i in 1:len){
fun <- get(ls.RFmg[i], envir=envir)
idx[i] <- is.function(fun) && is(fun, class2="RMmodelgenerator")
if (!idx[i]) next
idx[i] <- (!all(is.na(pmatch(type, fun["type"]))) &&
!all(is.na(pmatch(domain, fun["domain"]))) &&
!all(is.na(pmatch(isotropy, fun["isotropy"]))) &&
fun["operator"] %in% operator &&
fun["normalmix"] %in% normalmix &&
fun["finiterange"] %in% finiterange &&
(fun["maxdim"] < 0 ||
(fun["maxdim"] >= valid.in.dim[1] &&
fun["maxdim"] <= valid.in.dim[2])) &&
(fun["vdim"] < 0 ||
(fun["vdim"] >= vdim[1] && fun["vdim"] <= vdim[2])) &&
ls.RFmg[i] != ZF_INTERNALMIXED
)
}
return(sort(ls.RFmg[idx]))
}
RFformula <- function(f)
return(parseModel(f))
RFgetMethodNames <-function (show=TRUE) {
# frueher: PrintMethodList
if (show) .C("PrintMethods", PACKAGE="RandomFields")
#invisible()
# frueher: GetMethodNames
assign(".p", GetrfParameters(TRUE))
l <- character(.p$methodnr)
for (i in 1:.p$methodnr) {
l[i] <- .C("GetMethodName", as.integer(i - 1),
n = paste(rep(" ", .p$methodmaxchar), collapse = ""),
PACKAGE = "RandomFields")$n
}
invisible(l)
}