Nothing
# Author: Babak Naimi, naimi.b@gmail.com
# Date (last uodate): Feb. 2024
# Version 2.7
# Licence GPL v3
if (!isGeneric("add")) {
setGeneric("add", function(x,w,echo,...)
standardGeneric("add"))
}
setMethod('add', signature(x='list',w='character'),
function(x,w='sdm',echo=TRUE,...) {
#dot <- list(...)
if (missing(w)) w <- 'sdm'
if (missing(echo) || !is.logical(echo)) echo <- TRUE
if (w %in% c('sdm','sdmMethod','model','sdmCorrelativeMethod')) {
m <- do.call('.create.sdmCorrelativeMethod',x)
if (inherits(m,"sdmCorrelativeMethod")) {
.sdmMethods$addMethod(m,echo)
} else stop('The method is not added to the sdmMethods contrainer!')
}
}
)
if (!isGeneric("getmethod")) {
setGeneric("getmethod", function(x,w,...)
standardGeneric("getmethod"))
}
setMethod('getmethod', signature(x='character'),
function(x,w,...) {
#dot <- list(...)
if (missing(w)) w <- 'sdm'
if (w == 'sdm') {
if (!.sdmOptions$getOption('sdmLoaded')) .addMethods()
x <- .methodFix(x)
if (!is.na(x)) .sdmMethods$Methods[[x]]
else stop('the specified method does not exist!')
}
#n <- getmethodNames('sdm',FALSE)
}
)
if (!isGeneric("getmethodNames")) {
setGeneric("getmethodNames", function(w,...)
standardGeneric("getmethodNames"))
}
setMethod('getmethodNames', signature(w='ANY'),
function(w,alt,...) {
if (missing(w)) w <- 'sdm'
if (missing(alt)) alt <- TRUE
if (!.sdmOptions$getOption('sdmLoaded')) .addMethods()
if (w == 'sdm') {
m <- .sdmMethods$getMethodNames(alt=alt)
if (is.list(m)) data.frame(Methods=names(m),Aliases=sapply(m,function (x) paste(x,collapse = ', ')))
else m
}
}
)
.addMethods <- function() {
methodInfo <- NULL
#n <- getmethodNames('sdm',alt=FALSE)
n <- .sdmMethods$getMethodNames(alt=FALSE)
lst <- list.files(system.file("methods/sdm", package="sdm"),pattern='R$',full.names = TRUE)
for (l in lst) {
source(l,local=TRUE)
pkg <- methodInfo$packages
pkg <- pkg[!pkg == '.tmp']
if (!methodInfo$name[1] %in% n && all(.is.installed(pkg))) {
try(add(x=methodInfo,'sdm',echo=FALSE),silent = TRUE)
}
}
.sdmOptions$addOption('sdmLoaded',TRUE)
}
.create.sdmCorrelativeMethod <- function(name,packages=NULL,modelTypes=NULL,fitParams,fitSettings=NULL,settingRules=NULL,fitFunction,predictParams=NULL,predictSettings=NULL,predictFunction=NULL,tuneParams=NULL,metadata=NULL,...) {
m <- new('sdmCorrelativeMethod',name=name[1])
if (length(name) > 1) m@aliases <- name[2:length(name)]
Installed <- TRUE
if (!is.null(packages) && is.character(packages)) {
m@packages <- packages
#w <- rep(FALSE,length(m@packages))
w <- .is.installed(m@packages)
#if (!all(w)) print(paste('warning: packages (',paste(m@packages[!w],collapse=', '),') need to be installed to get this method working!',sep=''))
if (!all(w)) Installed <- FALSE
else {
for (i in seq_along(m@packages)) w[i] <- require(m@packages[i],character.only=TRUE)
}
} else m@packages <- NULL
if (!is.null(modelTypes)) {
modelTypes <- tolower(modelTypes)
for (i in 1:length(modelTypes)) {
if (modelTypes[i] %in% c('po','presenceonly','presence-only','presence')) {
modelTypes[i] <- 'po'
} else if (modelTypes[i] %in% c('pa','presenceabsence','presence-absence')) {
modelTypes[i] <- 'pa'
} else if (modelTypes[i] %in% c('pb','presenceb','presence-background','presence-pseudo','presence-pseudoabsence','ppa','psa')) {
modelTypes[i] <- 'pb'
} else if (modelTypes[i] %in% c('ab','abundance')) {
modelTypes[i] <- 'ab'
} else if (modelTypes[i] %in% c('n','nominal','multinominal')) {
modelTypes[i] <- 'n'
} else {
warning(paste('modelType',modelTypes[i],'is unknown, it is ignored!'))
modelTypes[i] <- NA
}
}
m@modelTypes <- modelTypes
}
#-------
if (is.list(fitParams)) {
n <- names(fitParams)
if (is.null(n)) stop('fitParams is not appropriately defined; example: list(formula="standard.formula",data="sdmDataFrame")')
m@fitParams <- fitParams
} else stop('fitParams should be a list')
#------
if (!is.null(fitSettings)) {
if (!is.list(fitSettings)) stop('fitSettings should be a list!')
n <- names(fitSettings)
if (is.null(n)) stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
if ('' %in% n) {
w <- which(n == '')
for (ww in w) {
if (is.character(n[ww])) names(fitSettings)[ww] <- n[w]
else stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
}
}
m@fitSettings <- fitSettings
}
#------
if (!is.null(settingRules)) {
if (!is.function(settingRules)) stop('settingRules should be a function!')
m@settingRules <- settingRules
}
#-----
if (inherits(fitFunction,"character")) {
if (length(strsplit(fitFunction,'::')[[1]]) == 2) fitFunction <- strsplit(fitFunction,'::')[[1]][2]
if (exists(fitFunction,mode='function')) {
if (environmentName(environment(get(fitFunction))) == "R_GlobalEnv") {
# assign to the environment in the container of methods!
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(fitFunction,get(fitFunction),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
# when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
}
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fitFunction,",params)}")))
} else if (length(strsplit(fitFunction,':::')[[1]]) == 2 && inherits(eval(parse(text=fitFunction)),'function')) {
if (!exists(strsplit(fitFunction,':::')[[1]][2],mode='function')) {
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(fitFunction,':::')[[1]][2],",params)}")))
} else {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(strsplit(fitFunction,':::')[[1]][2],eval(parse(text=fitFunction)),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(fitFunction,':::')[[1]][2],",params)}")))
}
} else if (!Installed) {
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fitFunction,",params)}")))
} else stop('fitFunction cannot be identified!')
} else if (inherits(fitFunction,'function')) {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
if (!paste(m@name,'_fit',sep='') %in% ls(envir=m@.temp.env)) fn <-paste(m@name,'_fit',sep='') ####
else stop('the user defined function in fitFunction cannot be registered because an object with a similar name exists in the container!')
assign(fn,fitFunction,envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
} else stop('fitFunction cannot be identified!')
#---------
if (!is.null(predictFunction)) {
if (inherits(predictFunction,"character")) {
if (length(strsplit(predictFunction,'::')[[1]]) == 2) predictFunction <- strsplit(predictFunction,'::')[[1]][2]
if (exists(predictFunction,mode='function')) {
if (environmentName(environment(get(predictFunction))) == "R_GlobalEnv") {
# assign to the environment in the container of methods!
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(predictFunction,get(predictFunction),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
# when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
}
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",predictFunction,",params)}")))
} else if (length(strsplit(predictFunction,':::')[[1]]) == 2 && inherits(eval(parse(text=predictFunction)),'function')) {
if (!exists(strsplit(predictFunction,':::')[[1]][2],mode='function')) {
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(predictFunction,':::')[[1]][2],",params)}")))
} else {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(strsplit(predictFunction,':::')[[1]][2],eval(parse(text=predictFunction)),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(predictFunction,':::')[[1]][2],",params)}")))
}
} else if (!Installed) {
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",predictFunction,",params)}")))
} else stop('predictFunction cannot be identified!')
} else if (inherits(predictFunction,'function')) {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
if (!paste(m@name,'_predict',sep='') %in% ls(envir=m@.temp.env)) fn <-paste(m@name,'_predict',sep='') ####
else stop('the user defined function in predictFunction cannot be registered because an object with a similar name exists in the container!')
assign(fn,predictFunction,envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
} else stop('predictFunction cannot be identified!')
#---------
if (!is.null(predictParams)) {
if (is.list(predictParams)) {
n <- names(predictParams)
if (is.null(n)) stop('predictParams is not appropriately defined; example: list(newdata="sdmDataFrame")')
m@predictParams <- predictParams
} else stop('predictParams should be a list')
}
if (!is.null(predictSettings)) {
if (is.list(predictSettings)) m@predictSettings <- predictSettings
else stop('predictSettings should be a list!')
}
}
#--------
if (!is.null(tuneParams)) {
if (!is.list(tuneParams)) stop('tuneParams should be a list; example: list(ntrees=seq(500,3000,by=200))')
n <- names(tuneParams)
if (is.null(n)) stop('tuneParams is not appropriately defined; example: list(ntrees=seq(500,3000,by=200))')
m@tuneParams <- tuneParams
}
#------------
if (inherits(metadata,'.Metadata')) m@metadata <- metadata
else m@metadata <- .newMetadata(...)
m
}
#--------
.update.sdmCorrelativeMethod <- function(m,...) {
name=NULL;packages=NULL;modelTypes=NULL;fitParams=NULL;fitSettings=NULL;settingRules=NULL;fitFunction=NULL;predictParams=NULL;predictSettings=NULL;predictFunction=NULL;tuneParams=NULL;metadata=NULL
dot <- list(...)
n <- tolower(names(dot))
for (i in seq_along(n)) {
if (any(!is.na(pmatch(c("nam"),n[i])))) name <- dot[[i]]
else if (any(!is.na(pmatch(c("pac"),n[i])))) packages <- dot[[i]]
else if (any(!is.na(pmatch(c("mod"),n[i])))) modelTypes <- dot[[i]]
else if (any(!is.na(pmatch(c("fits"),n[i])))) fitSettings <- dot[[i]]
else if (any(!is.na(pmatch(c("fitp"),n[i])))) fitParams <- dot[[i]]
else if (any(!is.na(pmatch(c("set"),n[i])))) settingRules <- dot[[i]]
else if (any(!is.na(pmatch(c("fitf"),n[i])))) fitFunction <- dot[[i]]
else if (any(!is.na(pmatch(c("predicts"),n[i])))) predictSettings <- dot[[i]]
else if (any(!is.na(pmatch(c("predictp"),n[i])))) predictParams <- dot[[i]]
else if (any(!is.na(pmatch(c("predictf"),n[i])))) predictFunction <- dot[[i]]
else if (any(!is.na(pmatch(c("tun"),n[i])))) tuneParams <- dot[[i]]
else if (any(!is.na(pmatch(c("met"),n[i])))) metadata <- dot[[i]]
}
#--------
if (length(name) > 1) m@aliases <- name[2:length(name)]
Installed <- TRUE
if (!is.null(packages) && is.character(packages)) {
m@packages <- packages
#w <- rep(FALSE,length(m@packages))
#for (i in seq_along(m@packages)) w[i] <- require(m@packages[i],character.only=TRUE)
w <- .is.installed(m@packages)
#if (!all(w)) print(paste('warning: packages (',paste(m@packages[!w],collapse=', '),') need to be installed to get this method working!',sep=''))
if (!all(w)) Installed <- FALSE
} else m@packages <- NULL
if (!is.null(modelTypes)) {
modelTypes <- tolower(modelTypes)
for (i in 1:length(modelTypes)) {
if (modelTypes[i] %in% c('po','presenceonly','presence-only','presence')) {
modelTypes[i] <- 'po'
} else if (modelTypes[i] %in% c('pa','presenceabsence','presence-absence')) {
modelTypes[i] <- 'pa'
} else if (modelTypes[i] %in% c('pb','presenceb','presence-background','presence-pseudo','presence-pseudoabsence','ppa','psa')) {
modelTypes[i] <- 'pb'
} else if (modelTypes[i] %in% c('ab','abundance')) {
modelTypes[i] <- 'ab'
} else if (modelTypes[i] %in% c('n','nominal','multinominal')) {
modelTypes[i] <- 'n'
} else {
warning(paste('modelType',modelTypes[i],'is unknown, it is ignored!'))
modelTypes[i] <- NA
}
}
m@modelTypes <- modelTypes
}
#-------
if (is.list(fitParams)) {
n <- names(fitParams)
if (is.null(n)) stop('fitParams is not appropriately defined; example: list(formula="standard.formula",data="sdmDataFrame")')
m@fitParams <- fitParams
} else stop('fitParams should be a list')
#------
if (!is.null(fitSettings)) {
if (!is.list(fitSettings)) stop('fitSettings should be a list!')
n <- names(fitSettings)
if (is.null(n)) stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
if ('' %in% n) {
w <- which(n == '')
for (ww in w) {
if (is.character(n[ww])) names(fitSettings)[ww] <- n[w]
else stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
}
}
m@fitSettings <- fitSettings
}
#------
if (!is.null(settingRules)) {
if (!is.function(settingRules)) stop('settingRules should be a function!')
m@settingRules <- settingRules
}
#-----
if (inherits(fitFunction,"character")) {
if (length(strsplit(fitFunction,'::')[[1]]) == 2) fitFunction <- strsplit(fitFunction,'::')[[1]][2]
if (exists(fitFunction,mode='function')) {
if (environmentName(environment(get(fitFunction))) == "R_GlobalEnv") {
# assign to the environment in the container of methods!
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(fitFunction,get(fitFunction),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
# when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
}
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fitFunction,",params)}")))
} else if (length(strsplit(fitFunction,':::')[[1]]) == 2 && inherits(eval(parse(text=fitFunction)),'function')) {
if (!exists(strsplit(fitFunction,':::')[[1]][2],mode='function')) {
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(fitFunction,':::')[[1]][2],",params)}")))
} else {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(strsplit(fitFunction,':::')[[1]][2],eval(parse(text=fitFunction)),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(fitFunction,':::')[[1]][2],",params)}")))
}
} else if (!Installed) {
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fitFunction,",params)}")))
} else stop('fitFunction cannot be identified!')
} else if (inherits(fitFunction,'function')) {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
if (!paste(m@name,'.fit',sep='') %in% ls(envir=m@.temp.env)) fn <-paste(m@name,'.fit',sep='') ####
else stop('the user defined function in fitFunction cannot be registered because an object with a similar name exists in the container!')
assign(fn,fitFunction,envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
} else stop('fitFunction cannot be identified!')
#---------
if (!is.null(predictFunction)) {
if (inherits(predictFunction,"character")) {
if (length(strsplit(predictFunction,'::')[[1]]) == 2) predictFunction <- strsplit(predictFunction,'::')[[1]][2]
if (exists(predictFunction,mode='function')) {
if (environmentName(environment(get(predictFunction))) == "R_GlobalEnv") {
# assign to the environment in the container of methods!
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(predictFunction,get(predictFunction),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
# when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
}
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",predictFunction,",params)}")))
} else if (length(strsplit(predictFunction,':::')[[1]]) == 2 && inherits(eval(parse(text=predictFunction)),'function')) {
if (!exists(strsplit(predictFunction,':::')[[1]][2],mode='function')) {
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(predictFunction,':::')[[1]][2],",params)}")))
} else {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
assign(strsplit(predictFunction,':::')[[1]][2],eval(parse(text=predictFunction)),envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",strsplit(predictFunction,':::')[[1]][2],",params)}")))
}
} else if (!Installed) {
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",predictFunction,",params)}")))
} else stop('predictFunction cannot be identified!')
} else if (inherits(predictFunction,'function')) {
if (is.null(m@.temp.env)) m@.temp.env <- new.env()
if (!paste(m@name,'.predict',sep='') %in% ls(envir=m@.temp.env)) fn <-paste(m@name,'.predict',sep='') ####
else stop('the user defined function in predictFunction cannot be registered because an object with a similar name exists in the container!')
assign(fn,predictFunction,envir = m@.temp.env) ####
m@packages <- unique(c(m@packages,'.temp'))
m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
} else stop('predictFunction cannot be identified!')
#---------
if (!is.null(predictParams)) {
if (is.list(predictParams)) {
n <- names(predictParams)
if (is.null(n)) stop('predictParams is not appropriately defined; example: list(newdata="sdmDataFrame")')
m@predictParams <- predictParams
} else stop('predictParams should be a list')
}
if (!is.null(predictSettings)) {
if (is.list(predictSettings)) m@predictSettings <- predictSettings
else stop('predictSettings should be a list!')
}
}
#--------
if (!is.null(tuneParams)) {
if (!is.list(tuneParams)) stop('tuneParams should be a list; example: list(ntrees=seq(500,3000,by=200))')
n <- names(tuneParams)
if (is.null(n)) stop('tuneParams is not appropriately defined; example: list(ntrees=seq(500,3000,by=200))')
m@tuneParams <- tuneParams
}
#------------
if (inherits(metadata,'.Metadata')) m@metadata <- metadata
else m@metadata <- .newMetadata(...)
m
}
#########
# .update.sdmCorrelativeMethod <- function(m,...) {
# name=NULL;packages=NULL;modelTypes=NULL;fitParams=NULL;fitSettings=NULL;settingRules=NULL;fitFunction=NULL;predictParams=NULL;predictSettings=NULL;predictFunction=NULL;tuneParams=NULL;metadata=NULL
#
# dot <- list(...)
# n <- tolower(names(dot))
# for (i in seq_along(n)) {
# if (any(!is.na(pmatch(c("nam"),n[i])))) name <- dot[[i]]
# else if (any(!is.na(pmatch(c("pac"),n[i])))) packages <- dot[[i]]
# else if (any(!is.na(pmatch(c("mod"),n[i])))) modelTypes <- dot[[i]]
# else if (any(!is.na(pmatch(c("fits"),n[i])))) fitSettings <- dot[[i]]
# else if (any(!is.na(pmatch(c("fitp"),n[i])))) fitParams <- dot[[i]]
# else if (any(!is.na(pmatch(c("set"),n[i])))) settingRules <- dot[[i]]
# else if (any(!is.na(pmatch(c("fitf"),n[i])))) fitFunction <- dot[[i]]
# else if (any(!is.na(pmatch(c("predicts"),n[i])))) predictSettings <- dot[[i]]
# else if (any(!is.na(pmatch(c("predictp"),n[i])))) predictParams <- dot[[i]]
# else if (any(!is.na(pmatch(c("predictf"),n[i])))) predictFunction <- dot[[i]]
# else if (any(!is.na(pmatch(c("tun"),n[i])))) tuneParams <- dot[[i]]
# else if (any(!is.na(pmatch(c("met"),n[i])))) metadata <- dot[[i]]
# }
# #--------
# if (!is.null(name)) {
# if (length(name) > 1) m@aliases <- name[2:length(name)]
# }
#
# if (!is.null(packages) && is.character(packages)) {
# m@packages <- packages
# w <- rep(FALSE,length(m@packages))
# for (i in seq_along(m@packages)) w[i] <- require(m@packages[i],character.only=TRUE)
# if (!all(w)) print(paste('warning: packages (',paste(m@packages[!w],collapse=', '),') need to be installed to get this method working!',sep=''))
# }
#
# if (!is.null(modelTypes)) {
# modelTypes <- tolower(modelTypes)
# for (i in seq_along(modelTypes)) {
# if (modelTypes[i] %in% c('po','presenceonly','presence-only','presence')) modelTypes[i] <- 'po'
# else if (modelTypes[i] %in% c('pa','presenceabsence','presence-absence')) modelTypes[i] <- 'pa'
# else if (modelTypes[i] %in% c('pb','presenceb','presence-background','presence-pseudo','presence-pseudoabsence','ppa','psa')) modelTypes[i] <- 'pb'
# else if (modelTypes[i] %in% c('ab','abundance')) modelTypes[i] <- 'ab'
# else if (modelTypes[i] %in% c('n','nominal','multinominal')) modelTypes[i] <- 'n'
# else {
# warning(paste('modelType',modelTypes[i],'is unknown, it is ignored!'))
# modelTypes[i] <- NULL
# }
# }
# m@modelTypes <- modelTypes
# }
#
# #-------
# if (!is.null(fitParams) && is.list(fitParams)) {
# n <- names(fitParams)
# if (is.null(n)) stop('fitParams is not appropriately defined; example: list(formula="standard.formula",data="sdmDataFrame")')
# m@fitParams <- fitParams
# }
# #------
# if (!is.null(fitSettings) && is.list(fitSettings)) {
# n <- names(fitSettings)
# if (is.null(n)) stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
# if ('' %in% n) {
# w <- which(n == '')
# for (ww in w) {
# if (is.character(n[ww])) names(fitSettings)[ww] <- n[w]
# else stop('fitSettings is not appropriately defined; example: list(family=link(binomial),ntrees=1000)')
# }
# }
# m@fitSettings <- fitSettings
# }
# #------
# if (!is.null(settingRules)) {
# if (!is.function(settingRules)) stop('settingRules should be a function!')
# m@settingRules <- settingRules
# }
# #-----
# if (!is.null(fitFunction) && exists(as.character(substitute(fitFunction)),mode='function')) {
# if (class(substitute(fitFunction)) == 'name') {
# fn <- as.character(substitute(fitFunction))
# if (environmentName(environment(fitFunction)) == "R_GlobalEnv") {
# # assign to the environment in the container of methods!
# if (is.null(m@.temp.env)) m@.temp.env <- new.env()
# assign(fn,fitFunction,envir = m@.temp.env) ####
# m@packages <- unique(c(m@packages,'.temp'))
# # when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
# }
# m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
#
# } else if (class(substitute(fitFunction)) == 'call') {
#
# if (environmentName(environment(fitFunction)) == "R_GlobalEnv" || environmentName(environment(fitFunction)) == "sdm") {
# if (is.null(m@.temp.env)) m@.temp.env <- new.env()
# if (!paste(m@name,'.fit',sep='') %in% ls(envir=m@.temp.env)) fn <- paste(m@name,'.fit',sep='') ####
# else stop('the user defined function in fitFunction cannot be registered because an object with a similar name exists in the container!')
#
# assign(fn,fitFunction,envir = m@.temp.env) ####
# m@packages <- unique(c(m@packages,'.temp'))
# } else {
# if (as.character(substitute(fitFunction))[1] == "::") fn <- as.character(substitute(fitFunction))[3]
# else stop('fitFunction cannot be identified!')
# }
#
# m@fitFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
# } else stop('fitFunction cannot be identified!')
#
# }
# #---------
#
# if (!is.null(predictFunction)) {
# if (exists(as.character(substitute(predictFunction)),mode='function')) {
#
# if (class(substitute(predictFunction)) == 'name') {
# fn <- as.character(substitute(predictFunction))
# if (environmentName(environment(predictFunction)) == "R_GlobalEnv" || environmentName(environment(predictFunction)) == "sdm") {
# # assign to the environment in the container of methods!
# if (is.null(m@.temp.env)) m@.temp.env <- new.env()
# assign(fn,predictFunction,envir = m@.temp.env) ####
# m@packages <- unique(c(m@packages,'.temp'))
# # when environment if attached, the conflict with the existing object in .GlobalEnv should be resolved!
# }
# m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
#
# } else if (class(substitute(predictFunction)) == 'call') {
#
# if (environmentName(environment(predictFunction)) == "R_GlobalEnv") {
# if (is.null(m@.temp.env)) m@.temp.env <- new.env()
# if (!paste(m@name,'.predict',sep='') %in% ls(envir=m@.temp.env)) fn <-paste(m@name,'.predict',sep='') ####
# else stop('the user defined function in predictFunction cannot be registered because an object with a similar name exists in the container!')
# assign(fn,predictFunction,envir = m@.temp.env) ####
# m@packages <- unique(c(m@packages,'.temp'))
# } else {
# if (as.character(substitute(predictFunction))[1] == "::") fn <- as.character(substitute(predictFunction))[3]
# else stop('predictFunction cannot be identified!')
# }
#
# m@predictFunction <- eval(parse(text=paste("function(params) {do.call(",fn,",params)}")))
# } else stop('predictFunction cannot be identified!')
#
# } else stop(paste("Function",as.character(substitute(predictFunction)),"is not found!"))
#
# if (!is.null(predictParams)) {
# if (is.list(predictParams)) {
# n <- names(predictParams)
# if (is.null(n)) stop('predictParams is not appropriately defined; example: list(newdata="sdmDataFrame")')
# m@predictParams <- predictParams
# } else stop('predictParams should be a list')
# }
#
# if (!is.null(predictSettings)) {
# if (is.list(predictSettings)) m@predictSettings <- predictSettings
# else stop('predictSettings should be a list!')
# }
# }
# #--------
# if (!is.null(tuneParams)) {
# if (!is.list(tuneParams)) stop('tuneParams should be a list; example: list(ntrees=seq(500,3000,by=200))')
# n <- names(tuneParams)
# if (is.null(n)) stop('tuneParams is not appropriately defined; example: list(ntrees=seq(500,3000,by=200))')
# m@tuneParams <- tuneParams
# }
# #------------
# if (inherits(metadata,'.Metadata')) m@metadata <- metadata
# else me <- .newMetadata(...)
# if(!is.null(me)) m@metadata <- me
# m
# }
#-----------
.movEnv <- function(e1,e2) {
n1 <- ls(envir = e1)
for (n in n1) assign(n,e1[[n]],envir = e2)
rm(list=n1,envir = e1)
e2
}
#----------
.movEnv2sdm <- function(e) {
n1 <- ls(envir = e)
for (n in n1) {
if (!exists(n,envir = as.environment("package:sdm"))) assign(n,e[[n]],envir = as.environment("package:sdm"))
}
rm(list=n1,envir = e)
}
#---------
.newMetadata <- function(...) {
dot <- list(...)
if (length(dot) > 0) {
w <- unlist(lapply(dot, function(x) inherits(x,'.Metadata')))
if (any(w)) return(dot[[which(w)]])
else {
ndot <- unlist(lapply(tolower(names(dot)),function(x) paste(strsplit(x,'')[[1]][1:3],collapse='')))
w <- ndot %in% c('ful','cre','aut','web','cit','hel','des','dat','lic','url')
if (any(w)) {
m <- new(".Metadata")
w <- which(ndot == 'aut')
if (length(w) > 0) {
if (is.list(dot[[w]])) m@authors <- dot[[w]]
else if (is.character(dot[[w]])) m@authors <- list(dot[[w]])
}
w <- which(ndot == 'cre')
if (length(w) > 0) {
if (is.list(dot[[w]])) m@creators <- dot[[w]]
else if (is.character(dot[[w]])) m@creators <- list(dot[[w]])
}
w <- which(ndot == 'tit')
if (length(w) > 0) m@title <- dot[[w]]
w <- which(ndot == 'url' | ndot == 'web')
if (length(w) > 0) m@url <- dot[[w]]
w <- which(ndot == 'cit')
if (length(w) > 0) m@citations <- dot[[w]]
w <- which(ndot == 'hel')
if (length(w) > 0) m@Help <- dot[[w]]
w <- which(ndot == 'des')
if (length(w) > 0) m@description <- dot[[w]]
w <- which(ndot == 'dat')
if (length(w) > 0) m@date <- dot[[w]]
w <- which(ndot == 'lic')
if (length(w) > 0) m@license <- dot[[w]]
return(m)
}
}
}
}
#################################################
###############
.sdmMethods <- new('.sdmMethodsContainer')
#
# #################
# .sdmMethods$getFitFunctions(c('glm','brt'))
#
#
#
#
#
#
#
#
#
# m@fitFunction
# m@predictFunction
# m@.temp.env
# m@metadata
# m@settingRules
# m <- eval(m)
# saveRDS(m,'glm_model.rds')
# saveRDS(.create.sdmCorrelativeMethod(name='glm',modelTypes = 'pa',fitParams = list(formula='sdmFormula',data='sdmDataFrame'),
# fitSettings = list(family=binomial(link='logit'),weights=NULL,model=FALSE),fitFunction = glm,
# predictParams=list(object='sdmModel',newdata='sdmDataFrame'),
# predictSettings=list(type='response'),predictFunction=predict.glm),file='glm_model.rds')
#
# readRDS('glm_model.rds')
# save(m,file='glm_model.RData')
# eval(get(load('glm_model.RData')))
# rm(m)
# sa
# m
#
# #############
# m <- .create.sdmCorrelativeMethod(name='glm',modelTypes = 'pa',fitParams = list(formula='sdmFormula',data='sdmDataFrame'),
# fitSettings = list(family=binomial(link='logit'),weights=NULL,model=FALSE),fitFunction = glm,
# predictParams=list(object='sdmModel',newdata='sdmDataFrame'),
# predictSettings=list(type='response'),predictFunction=predict.glm)
#
#
# a <- .sdmMethods$new()
#
# a$addMethod(m)
# a$getPredictFunctions()
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.