## Authors ## Martin Schlather, schlather@math.uni-mannheim.de ## ## ## 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. ## meta-function that generates functions like RMplus, RMwhittle, which ## the user will use to generate explicit covariance models, i.e. objects ## of class 'RMmodels' param.text.fct <- function(catheg, nick, names, havedistr=TRUE, Const=NULL, ismath=FALSE){ ifHasArg <- paste(" if (hasArg('", names, "') && !is.null(subst <- substitute(", names, "))) \n", sep="") if (ismath && any(idx <- names == "new" & Const == NN2)) { ifHasArg[idx] <- " if (!(hasArg('new') && !is.null(subst <- substitute(new)))) new <- UNREDUCED\n" } x <- paste(ifHasArg, "\t", catheg, "[['", names, "']] <- ", sep="") for (i in 1:length(names)) { if (#!ismath && ## deleted Feb 2017 names[i] == "proj") x[i] <- paste(x[i], "CheckMixed(proj, subst, PROJECTION_NAMES)", sep="") ## Version brasilien ## x[i] <- paste(x[i], "CheckProj(proj, subst)", sep="") else if (length(Const) > 0 && Const[i] == MixedInputType) x[i] <- paste(x[i], "CheckMixed(", names[i], ", subst, ", toupper(nick), "_", toupper(names[i]), # ", ", havedistr, ")", sep="") else if (length(Const) > 0 && Const[i] == CharInputType) x[i] <- paste(x[i], "CheckChar(", names[i], ", subst, ", toupper(nick), "_", toupper(names[i]), ## ", ", havedistr, ", FALSE", ")", sep="") else if (length(Const) > 0 && Const[i] >= NN1) x[i] <- paste(x[i], "CheckChar(", names[i], ", subst, ", NAMES_OF_NAMES[Const[i] - NN1 + 1], ", ", havedistr, ")", sep="") else if (ismath) x[i] <- paste(x[i], "CheckMaths(", names[i], ", subst, ", havedistr, ")", sep="") else x[i] <- paste(x[i], "CheckArg(", names[i], ", subst, ", havedistr, ")", sep="") } x } rfGenerateModels <- function(package="RandomFields", assigning, RFpath = "~/svn/RandomFields/RandomFields", RMmodels.file = paste(RFpath, "R/RMmodels.R", sep="/"), PL = RFoptions()$basic$printlevel ) { # if file already exists, remove it. if (assigning && file.exists(RMmodels.file)) file.remove(RMmodels.file) write(file = RMmodels.file, append = TRUE, "\n## This file has been created automatically by 'rfGenerateModels'.\n\n") ## defined constants diminf <- 999999 # define empty strings empty <- paste(rep(" ", MAXCHAR_RF), collapse="") empty2 <- paste(rep(" ", MAXCHAR_RF), collapse="") # inialized attribute parameter nr <- GetCurrentNrOfModels() vn <- nr * MAXVARIANTS # get attribute parameter A <- .C(C_GetAttr, nr=integer(vn), type=integer(vn), operator=integer(vn), monotone=integer(vn), finiterange=integer(vn), simpleArguments=integer(vn), internal=integer(vn), domains=integer(vn), isos=integer(vn), maxdim=integer(vn), vdim=integer(vn), includevariants= as.integer(TRUE), paramtype = integer(vn * MAXPARAM), va = integer(1) ) va <- A$va dim(A$paramtype) <- c(MAXPARAM, vn) i <- 1 while (i <= va) { step <- 1 ## sequential steps for each model if (A$internal[i] && A$internal[i] != INTERN_SHOW) { if (PL > 1) cat(i, "internal", .C(C_GetModelName,as.integer(A$nr[i]), name=empty, nick=empty2)$name,"\n") i <- i + 1 next } domains <- A$domains[i] if (domains == PREVMODEL_D) domains <- c(XONLY, KERNEL) # get model name ret <- .C(C_GetModelName,as.integer(A$nr[i]), name=empty, nick=empty2) internal.nick <- nick <- ret$nick if (A$internal[i]) internal.nick <- paste("i", internal.nick, sep="") ismath <- substr(nick, 1, 2) == "R." #if (PL > 1)cat(i, nick, "\n"); type <- A$type[i] iso <- A$isos[i] while (i + step <= va && nick == .C(C_GetModelName,as.integer(A$nr[i + step]), name=empty, nick=empty2)$nick) { if (PL > 1)cat("...variant added\n") type <- c(type, A$type[i + step]) iso <- c(iso, A$isos[i + step]) step <- step + 1 } finiterange <- as.logical(A$finiterange) finiterange[A$finiterange < 0] <- NA ## get names of submodels subname.info<- .Call(C_GetSubNames, as.integer(A$nr[i])) subnames <- subname.info[[1]] subintern <- subname.info[[2]] subnames.notintern <- subnames[!subintern] # get names of parameters paramnames <- .Call(C_GetParameterNames, as.integer(A$nr[i]) ) internal <- which(paramnames == INTERNAL_PARAM) if (length(internal) > 0) paramnames <- paramnames[-internal] elmnt <- which(paramnames == "element") if (length(elmnt) > 0) { stopifnot(length(elmnt) == 1) paramnames <- c(paramnames[-elmnt], "element") } par.intern <- paramnames %in% subnames if (any(par.intern)) stop(nick, ": subnames (", paste(subnames, collapse=", "), ") and parameter names (", paste(paramnames, collapse=", "), ") match.") ex.anysub <- length(subnames)>0 ex.sub <- length(subnames.notintern)>0 ex.par <- length(paramnames)>0 ex.std <- ((nick != DOLLAR[2] && any(isVariogram(type))) || nick %in% c("RMball", "RMsum", "RMconstant", "RMfixcov", "RMcovariate") || nick == RM_PLUS[1] || nick[1] == RM_MULT[1]) && !(nick %in% c("RMtrafo", "RMsine")) && !ismath std.variables <- if (nick %in% c("RMid")) NULL else if (nick %in% c("RMfixcov")) c("var", "proj") else if (nick %in% c("RMconstant", "RMcovariate")) "var" else if (nick == "RMnugget") c("var", "Aniso", "proj") else c("var", "scale", "Aniso", "proj") # cat(nick, ":", std.variables, "\n") # if (PL > 1) cat( std.variables, ex.std) #stopifnot(i < 50) if (PL > 1)cat(i, "\t", internal.nick, ",\t", paste(std.variables, collapse=", "), "\t", ex.std, "\t", paste(DOMAIN_NAMES[domains+1], collapse="; "), "\t", paste(type, collapse="/"), "\n", sep="") if(nick == DOLLAR[2]){ text.fct.head <- paste(nick, " <- function(phi, var, scale, Aniso, proj, anisoT)") ##Print(type, isVariogram(type), ShapeType, paramnames, A$paramtype[,i]) } else { text.fct.head <- paste(internal.nick, " <- function(", if (ex.sub) { paste(paste(subnames.notintern, collapse=", "), sep="") }, if (ex.sub && (ex.par || ex.std)) ", ", if (ex.par) { paste(paste(paramnames, collapse=", "), sep="") }, if (ex.par && ex.std) ", ", if (ex.std) paste(std.variables, collapse =", "), ")", sep="") } if (ex.par) { par.body <- param.text.fct(catheg="par.model", nick=nick, names=paramnames, havedistr=any(isVariogram(type)) || any(type==ShapeType) # || any(type==RandomOrShapeType) , Const=A$paramtype[1:length(paramnames), i], ismath=ismath) if (any(idx <- paramnames == 'envir')) warning(internal.nick, ": envir not internal") # if (any(idx)) # par.body[idx] <- # "par.model[['envir']] <- if (hasArg(envir)) envir else new.env()" } else par.body <- NULL text.fct.body <- paste("{\n ", "cl <- match.call()", "\n ", "submodels <- par.general <- par.model <- list() \n ", ## get submodels if (ex.anysub) { paste("if (hasArg(", subnames, ")) submodels[['", subnames, "']] <- ", subnames, sep="", collapse="\n ") }, if (ex.anysub) "\n ", "\n", ## get model specific parameter if (ex.par) paste(par.body, collapse="\n"), if (ex.par) "\n ", ## get general model parameter if (ex.std) { paste(param.text.fct(catheg="par.general", nick=nick, names=std.variables), collapse="\n ") }, "\n ", # create RMmodel object "model <- methods::new('", CLASS_CLIST, "', ", "call = cl, ", "name = ", "'", nick, "'", ", \n \t\t", "submodels = submodels, ", "\n \t\t", "par.model = par.model, ", "par.general = par.general)", "\n ", "return(model)\n}\n", sep="" ) text.fct <- paste(text.fct.head, text.fct.body) # assign class CLASS_RM (CLASS_RM) and attributes like stationarity # to the function: text.assign.class <- paste(internal.nick, " <- new(CLASS_RM, \n\t", ".Data = ", internal.nick, ",", "\n\t", "type = ", "c('", paste(TYPE_NAMES[type+1], collapse="', '"), "'),", "\n\t", "isotropy = ", "c('", paste(ISO_NAMES[iso+1], collapse="', '"), "'),", "\n\t", "domain = ", "c('", paste(DOMAIN_NAMES[domains+1], collapse="', '"), "'),", "\n\t", "operator = ", as.logical(A$operator[i]), ",", "\n\t", "monotone = ", "'", MONOTONE_NAMES[A$monotone[i] + 1 - MON_UNSET], "',", "\n\t", "finiterange = ", finiterange[i], ",", "\n\t", "simpleArguments = ", as.logical(A$simpleArguments[i]), ",", "\n\t", "maxdim = ", if(A$maxdim[i]>diminf) Inf else A$maxdim[i], ",", "\n\t", "vdim = ", A$vdim[i], "\n\t", ")", sep="") text <- paste(text.fct, "\n", text.assign.class, "\n\n\n", sep="") if (internal.nick == "RMwhittle") { if (PL > 1)cat(text.assign.class) # stop("KKKK") } if (assigning) { #sink(file = RMmodels.file, append = TRUE, type='output') write(file = RMmodels.file, append = TRUE, text) #if (PL > 1) cat(text) #sink() #unlink(RMmodels.file) } i <- i + step } ## matches for (i in 1:nr) # if help page to the function does not exist, throw warning if (length(as.character(help(nick))) == 0) { if (file.exists("/home/schlather/R/RF/RandomFields/R/rf.RXX")|| file.exists("do.not.rm.this.file")) { if (!any(nick == c("list of exceptions"))) { warn <- paste("Warning: help page for '", nick,"' does not exist.", sep="") cat(warn, "\n") } } } invisible() } clean_value <- function(s) { s <- clean_name(s) if (s == "NA_INTEGER") s <- "as.integer(NA)" return(s) } kind <- function(Zeilen, i, start, cont="", ignore=" ", endofname=" ", stops=NULL) { if (substr(Zeilen[i], 1, nchar(start)) == start) { s <- substring(Zeilen[i], nchar(start) + 1) j <- 2 while (j <= nchar(s) && substr(s, j, j) != endofname) j <- j + 1 stopifnot(j <= nchar(s)) name <- substr(s, 1, j -1) u <- strsplit(substring(s, j + 1), "//")[[1]] kommentar <- paste(u[-1], collapse = " ") RC <- nchar(kommentar) > 0 && nchar(strsplit(kommentar, "RC")[[1]][1]) < nchar(kommentar) value <- u <- clean_value(u[1]) i <- i + 1 RCX <- NULL if (any(cont != "")) { repeat { if (i > length(Zeilen) || (length(stops) > 0 && length(strsplit(u, stops)[[1]]) > 1)) break; ## cat(i, " >>", Zeilen[i], "<<\n", sep="") j <- nchar(u) if (ignore != "") while (substr(u, j, j) %in% ignore) { j <- j - 1 } ## print(u); print(j) ;print(cont) ##print(c(substr(u, j,j), cont, !(substr(u, j,j) %in% cont) , j)) if (!(substr(u, j,j) %in% cont) && j > 0) break while (Zeilen[i] == "") i <- i + 1 u <- strsplit(Zeilen[i], "//")[[1]] kommentar <- paste(u[-1], collapse = " ") u <- u[1] RCX <- c(RCX, nchar(kommentar) > 0 && nchar(strsplit(kommentar, "RC")[[1]][1]) < nchar(kommentar)) value <- paste(value, clean_value(u[1])) ## cat("u=", u, "\n") i <- i + 1 } } res <- list(name=name, value=value, RC=if (length(RCX) == 0 || all(!RCX)) RC else RCX, i=i) ## cat("value=", value, "\n\n") return(res) } else return(NULL) } clean_name <- function(x) { ## str(x) coll <- paste(strsplit(x, "\t")[[1]], collapse="") i <- 1 while(i <= nchar(coll)) { ## Print(i, coll, substr(coll, i, i)) if (substr(coll, i, i) %in% c("\"", "'")) { repeat { i <- i + 1 if (substr(coll, i, i) %in% c("\"", "'")) { i <- i + 1 break; } } } if (substr(coll, i, i) == " ") { coll <- paste0(substr(coll, 1, i-1), substr(coll, i+1, nchar(coll))) } else i <- i + 1 ## x <- paste(strsplit(coll, " ")[[1]], collapse=""); Print(x); xx } ## Print(coll) coll } CC <- function(x, envir) { if (is.numeric(x)) { Real <- TRUE Integer <- x == as.integer(x) y <- x } else { stopifnot(is.character(x)) if (substr(x, 1, 1) =='"') #'"') return(x) warn <- options()$warn options(warn = -1) y <- try(as.numeric(eval(parse(text=x), envir=envir)), silent=TRUE) options(warn = warn) if (Real <- !is(y, "try-error") && !is.na(y)) { Integer <- nchar(strsplit(x, "\\.")[[1]][1]) == nchar(x) && abs(y) <= .Machine$integer.max ## cat(Integer, "", y,"", .Machine$integer.max, "",abs(y) <= .Machine$integer.max) } else Real <- Integer <- FALSE y <- paste(strsplit(paste(strsplit(x, "\t")[[1]], collapse=""), " ")[[1]], collapse="") } if (Real) { y <- paste("as.", if (Integer) "integer" else "double", "(", y, ")", sep="") } return(y) } rfGenerateConstants <- function(package="RandomFields", aux.package = "RandomFieldsUtils", RFpath = paste0("~/svn/",package, "/", package), RCauto.file = paste(RFpath, "R/aaa_auto.R", sep="/"), header.source = c(if (length(aux.package) > 0) paste0("../../", aux.package,"/", aux.package, "/src/Auto", aux.package, ".h"), paste0("src/Auto",package,".h")), c.source = paste0("src/Auto", package, ".cc")) { write(file = RCauto.file, "# This file has been created automatically by 'rfGenerateConstants'") envir <- new.env() for (s in header.source) { write(file = RCauto.file, append = TRUE, paste("\n\n ## from ", s)) rfGenerateConstantsHeader(RFpath = RFpath, RCauto.file=RCauto.file, header.source = s, envir=envir) } cat("** header files done\n"); for (s in c.source) { write(file = RCauto.file, append = TRUE, paste("\n\n ## from ", s)) rfGenerateConstantsC(package = package, RFpath = RFpath, RCauto.file=RCauto.file, c.source = s) } } rfGenerateConstantsHeader <- function(RFpath, RCauto.file, header.source, envir) { s <- scan(paste(RFpath, header.source, sep="/"), what=character(), sep="\n", blank.lines.skip=FALSE, skip=2) #if (PL > 1)for (i in 1:length(s)) cat(s[i], "\n") i <- 1 typedef <- character(0) ## nur fuer alte defs a la "typedef int dom_type;" while (i <= length(s)) { if (!is.null(k <- kind(s, i, start="#define", cont="\\", ignore=""))) { ## if (i>130 && i<140) value <- clean_value(k$value) if (length(typedef) > 0) for (j in 1:length(typedef)) { value <- paste(strsplit(value, typedef[j])[[1]], collapse=" ") } v <- clean_name(k$name) ## Print(i, k, v); stopifnot(i < 70) if (v != "") { w <- if (k$RC) paste("RC_", v, " <-", sep="") else "" line <- paste(w, v , "\t<-", CC(value, envir=envir)) eval(parse(text=line), envir=envir) write(file = RCauto.file, append = TRUE, line) } } else if (!is.null(k <- kind(s, i, start ="typedef enum", cont=c(",", "{"), ignore=" ", stops=";"))) { # ##Print(i, k, v); stopifnot(i < 72) value <- strsplit(clean_value(k$value), "\\{")[[1]] if (value[1] != "") typedef <- c(typedef, paste("\\(", strsplit(value[1], ";")[[1]][1] , "\\)", sep="")) value <- strsplit(strsplit(value[2], "\\}")[[1]][1], ",")[[1]] zaehler <- 0 for (j in 1:length(value)) { v <- clean_value(value[j]) ## Print(v, value) if (v != "") { w <- if ((length(k$RC) == 1 && k$RC) || (length(k$RC) > 1) && k$RC[j]) paste("RC_", v, " <-", sep="") else "" v <- strsplit(v, "=")[[1]] if (length(v) > 1) { stopifnot(length(v) == 2) nr <- v[2] v <- v[1] } else { nr <- zaehler zaehler <- zaehler + 1 } line <- paste(w, v , "\t<-", CC(nr, envir=envir)) eval(parse(text=line), envir=envir) write(file = RCauto.file, append = TRUE, line) } } write(file = RCauto.file, append = TRUE, "") } else if (!is.null(k <- kind(s, i, start="typedef", cont="\\", ignore="", stops=";"))) { if (value[1] != "") typedef <- c(typedef, paste("\\(", strsplit(k$value, ";")[[1]][1] ,"\\)", sep="")) } else if (!is.null(k <- kind(s, i, start="extern const", cont=",", ignore=" ", stops=";"))) { ## ignored } else write(file = RCauto.file, append = TRUE, "") i <- if (is.null(k)) i+1 else k$i } } rfGenerateConstantsC <- function(RFpath, RCauto.file, c.source, package="none") { s <- scan(paste(RFpath, c.source, sep="/"), what=character(), sep="\n", blank.lines.skip=FALSE, skip=1) i <- 1 nl <- TRUE while (i <= length(s)) { if (!is.null(k <- kind(s, i, " *", c(",", "{"), " ", endofname="[", stops="}"))) { ## Print(k); stopifnot(k$i != 55) value <- strsplit((clean_value(k$value)), "\\{")[[1]] value <- strsplit(value[2], "\\}")[[1]][1] v <- clean_name(k$name) if (v != "") { w <- if (k$RC) paste("RC_", v, " <-", sep="") else "" line <- paste(w, v, "<-\nc(", value, ")") write(file = RCauto.file, append = TRUE, line) write(file = RCauto.file, append = TRUE, "") nl <- TRUE } } else if (nl) { write(file = RCauto.file, append = TRUE, "") nl <- FALSE } i <- if (is.null(k)) i+1 else k$i } if (package == "RandomFields") { define_char <- function(name, value) { if (is(value, "try-error")) value <- NULL write(file = RCauto.file, append = TRUE, paste("\n", name, " <- c('", sep="", paste(value, collapse="', '"), "')") ) } define_num <- function(name, value) { if (is(value, "try-error")) value <- NULL write(file = RCauto.file, append = TRUE, paste("\n", name, " <- c(", sep="", paste(value, collapse=", "), ")") ) } envir <- as.environment("package:RandomFields") all <- ls(envir=envir) genuine <- all[substr(all, 1, 2) %in% c("iR", "RM", "R.", "RP" ,"RF", "RR")] define_char("list2RMmodel_Names", genuine) ##, RM_TREND define_char("list2RMmodel_oldNames", try(RFgetModelNames(newnames=FALSE))) # , RM_INTERNALMIXED names1 <- c("RMwhittle", RFgetModelNames(type=TYPE_NAMES[c(TcfType, PosDefType) + 1], isotropy=ISO_NAMES[ISOTROPIC + 1], operator=FALSE, group.by=NULL, valid.in.dim = 1,#if (sim_only1dim)1 else 2, simpleArguments = TRUE, vdim=1)) do.not.include <- c("RMnugget", # macht kaum sinn "RMwendland","RMcardinalsine","RMpoweredexp", # aliase "RMparswmX", "RMtent", # convenience models "RMconstant", ## macht aerger "RMlsfbm", ## nur fuer |x| < 1 definiert "RMdagum", ## internal parameter "RMgneiting" ## integer parameter ) names1 <- sort(names1[!(names1 %in% do.not.include)]) define_char("rfgui1_Names", names1) names2 <- c("RMwhittle", RFgetModelNames(type=TYPE_NAMES[c(TcfType, PosDefType) + 1], isotropy=ISO_NAMES[ISOTROPIC + 1], operator=FALSE, group.by=NULL, valid.in.dim = 2,#if (sim_only1dim)1 else 2, simpleArguments = TRUE, vdim=1)) names2 <- sort(names2[!(names2 %in% do.not.include)]) define_char("rfgui2_Names", names2) } return(NULL) } rfGenerateTest <- function(package = "RandomFields", files = NULL, RFpath = paste0("~/svn/", package, "/", package)) { start.after <- "\\dontrun" end.before <- c("\\", "}") initial.text <- "if (RFoptions()$internal$do_tests){" final.text <- "}" comment <- "%" if (length(files) == 0) return() ncomment <- nchar(comment)[1] nendbefore <- nchar(end.before)[1] for (f in 1:length(files)) { cat("creating ", files[f], ".R\n", sep="") s <- scan(paste(RFpath, "/man/", files[f], ".Rd", sep=""), what=character(), sep="\n", blank.lines.skip=FALSE, skip=2) i <- 1 while (i <= length(s) && substr(s[i], 1, nchar(start.after)) != start.after) i <- i + 1 i <- i + 1 if (i <= length(s)) for (j in i:length(s)) { if (substr(s[j], 1, ncomment) %in% comment) s[j] <- "" if (substr(s[j], 1, nendbefore) %in% end.before) { j <- j -1 break; } } if (j >= i) { out <- paste(RFpath, "/tests/", files[f], ".R", sep="") write(file = out, append = FALSE, initial.text) write(file = out, append = TRUE, s[i:j]) write(file = out, append = TRUE, final.text) } } return(NULL) } .R.fmax <- function(...) { a <- list(...) if (length(a) == 1) if (is(a[[1]], CLASS_CLIST)) a[[1]] else R.c(a[[1]]) else R.fmax(if (is(a[[1]], CLASS_CLIST)) a[[1]] else R.c(a[[1]]), do.call(".R.fmax", a[-1])) } .R.fmin <- function(...) { a <- list(...) if (length(a) == 1) if (is(a[[1]], CLASS_CLIST)) a[[1]] else R.c(a[[1]]) else R.fmin(if (is(a[[1]], CLASS_CLIST)) a[[1]] else R.c(a[[1]]), do.call(".R.fmin", a[-1])) } rfGenerateMaths <- function(package = "RandomFields", files = "/usr/include/tgmath.h", do.cfile = FALSE, ## copy also in ../private/lit Cfile = "QMath", Rfile = "RQmodels", RFpath = paste0("~/svn/",package,"/", package)) { prefix <- "R." start.after <- "/* Unary functions" end.before <- c("#define carg") initial.text <- "if (RFoptions()$internal$do_tests){" final.text <- "}" comment <- c("/*", "#i", "#e") nendbefore <- nchar(end.before)[1] if (FALSE) { stopifnot(length(files) > 0) if (do.cfile) { cfile <- paste(RFpath, "/src/", Cfile, ".cc", sep="") write(file = cfile, c("// This file has been created automatically by 'rfGenerateMaths'", "#include ", "#include \"RF.h\"", "#include \"primitive.h\"" )) } manfile <- paste(RFpath, "/man/", Cfile, ".Rd", sep="") write(file = manfile, scan(paste(manfile, 0, sep="."), what=character(), sep="\n", blank.lines.skip=FALSE, skip=0)) Rfile <- paste(RFpath, "/R/", Rfile, ".R", sep="") write(file = Rfile, "# This file has been created automatically by 'rfGenerateMaths'") usage <- include <- list() for (f in 1:length(files)) { cat("scanning ", f, files[f],"\n") s <- scan(files[f], what=character(), sep="\n", blank.lines.skip=FALSE, skip=0) i <- 1 while (i <= length(s) && substr(s[i], 1, nchar(start.after)) !=start.after){ i <- i + 1 } i <- i + 1 usage[[f]] <- include[[f]] <- rep("", length(s)) while (i <= length(s)) { if (substr(s[i], 1, nendbefore) %in% end.before) break if (!is.null(k <- kind(s, i, start="#define", cont="\\", ignore=" ", endofname=")"))) { x <- strsplit(k$name, "\\(") name <- clean_name(x[[1]][1]) if (name == "") { i <- i + 1; next } if (!(name %in% c("frexp", "ldexp", "remquo", "scalbn", "scalbln", #"ilogb", "fma"))) { args <- length(strsplit(x[[1]][2], ",")[[1]]) #cat(name, args, k$name, "\n") if (do.cfile) { write(file = cfile, append = TRUE, paste("void Math", name, "(double *x, cov_model *cov, double *v){", "\nMATH_DEFAULT\n", sep="")) write(file = cfile, append = TRUE, if (name %in% c("cos", "sin", "tan")) { paste("*v = ", name, "(GLOBAL.coords.anglemode == radians", " ? w[0] : w[0] * piD180);", sep="") } else if (name %in% c("acos", "asin", "atan", "atan2")) { paste("*v = ", name, "(w[0]", if (args == 2) ", w[1]", ");\n", "if (GLOBAL.coords.anglemode == degree) *v/=piD180);", sep="") } else { paste("*v = ", name, "(w[0]", if (args == 2) ", w[1]", ");", sep="") }) write(file = cfile, append = TRUE, "\n}\n\n") include[[f]][i] <- paste( 'IncludeModel(".', name, '", MathDefType, 0, 0, ', args, ', NULL, XONLY,\n\t',## auch fuer kernel schreiben?? 'PREVMODEL_I,checkMath,rangeMath, PREF_TREND,\n\t', 'false, SCALAR, PREVMODEL_DEP, false, false); \n', 'nickname("', name, '");\n', 'kappanames("a", REALSXP', if (args == 2) ', "b", REALSXP', ');\n', 'addCov(Math', name, ', NULL, NULL);\n', 'AddVariant(TrendType, PREVMODEL_I);\n', sep="") } write(file = manfile, append = TRUE, paste("\\alias{", prefix, name, "}", sep="")) usage[[f]][i] <- paste(prefix, name, "(a", if (args == 2) ", b", ")", sep="") if (name %in% c( "asin", "atan", "atan2", "cos", "sin", "tan", "acosh", "asinh", "atanh", "cosh", "sinh", "tanh", "exp", "log", "expm1", "log1p", #"logb", "exp2", "log2", "pow", "sqrt", "hypot", "cbrt", "ceil", "fabs", # abs "floor", "fmod", "round", "trunc", "erf", "erfc", "gamma", # gamma "lgamma", #"nearbyint", #"lrint", #"llrint", #"lround", #"llround", #"copysign", #"rint", #"nextafter", #"nexttoward", #"remainder", #"fdim", "fmax", "fmin")) { Rname <- switch(name, "fabs" = "abs", "pow" = "^", "fmin" = "min", "fmax" = "max", "fmod" = "%%", "ceil" = "ceiling", name) ## if (name == "fabs") "abs" else #### if (name == "tgamma") "gamma" else ## if (name == "pow") "^" else ## if (name == "fmin") "min" else ## if (name == "fmax") "max" else name write(file = manfile, append = TRUE, paste("\\alias{", if (Rname=="%%") "\\%\\%" else Rname, "}", sep="")) args <- switch(Rname, "atan2" = "y, x", "min" = "...", "max" = "...", "round" = "x, digits=0", "^" = "x, y", "%%" = "x, y", # "logb" = "x, base=exp(1)", "x") innerargs <- switch(Rname, "round" = "x", args) CLASS_CLIST_ANY <- c("c(CLASS_CLIST,'ANY')", "c('ANY',CLASS_CLIST)") signature <- switch(Rname, "round" = "c(CLASS_CLIST, 'missing')", # "logb" = "c(CLASS_CLIST, 'missing')", "^"=CLASS_CLIST_ANY, "%%"=CLASS_CLIST_ANY, "atan2"=CLASS_CLIST_ANY, "CLASS_CLIST") if (args != "...") usage[[f]][i] <- paste(Rname, "(", args, ")\n", usage[[f]][i], sep="") write(file = Rfile, append=TRUE, if (exists(Rname, envir=parent.env(parent.env(.GlobalEnv)))) { if (args != "...") paste(sep="", "setMethod(\"", Rname, "\", signature = ", signature, ", definition=function(", args, ") ", prefix, name, "(", innerargs, "))") else { if (FALSE) paste(Rname, " <- function(", args, ") if (any(sapply(list(", args, "), function(x) is(x, \"", CLASS_CLIST, "\")))) .", prefix, name, "(", args, ") else ", "base::", Rname,"(", args, ")", sep="") } } else paste(sep="", name, " <- ", prefix, name) ) } } # !name in } # !is.null k i <- if (is.null(k)) i+1 else k$i } ## while i <= length } # for 1:files if (do.cfile) write(file = cfile, append=TRUE, "void includeStandardMath() {") write(file = manfile, append=TRUE, scan(paste(manfile, 1, sep="."), what=character(), sep="\n", blank.lines.skip=FALSE, skip=0)) for (f in 1:length(files)) { if (do.cfile) write(file = cfile, append=TRUE, include[[f]][include[[f]] != ""]); write(file = manfile, append=TRUE, usage[[f]][usage[[f]] != ""]); } if (do.cfile) write(file = cfile, append=TRUE, "}") write(file = manfile, append=TRUE, scan(paste(manfile, 2, sep="."), what=character(), sep="\n", blank.lines.skip=FALSE, skip=0)) } ## NO QMath.* generated anymore return(NULL) }