R/criaModeloGenerico2.R

In ITGM: Individual Tree Growth Modeling

## Copyright (C) 2016  Clayton Vieira Fraga Filho
##
## 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 2
## 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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
##' @title Create function with generic model
##' @description This function creates a generic model that will be a funcao that has parameters for the variables that can be mapped to each different base. her return will be a generic model that should be mapped to be used by the function avaliaEstimativas
##' @param nome is the name of model
##' @param formula is the string formula begin with y2~y1
##' @param funcaoRegressao is the function that will make the regression, ex.: 'nlsLM'
##' @param variaveis list variables that are present in the model that are field database
##' @param palpite param start of funcaoRegressao
##' @param maisParametros string add in funcaoRegressao, ex lm(y2~y1, data=base, maisParametros)
##' @param requires list of string of packges used to work with funcaoRegressao
##' @return will be returned function with generic model to map to a base
##' @export
criaModeloGenerico2 <- function (
  nome,
  formula,
  funcaoRegressao,
  variaveis,
  palpite = NULL,
  maisParametros = NULL,
  requires = NULL) {
  if (is.null(nome) || is.null(formula) || is.null(funcaoRegressao) ||
      is.null(variaveis))
    stop("os parametros nome, formula, funcaoRegressao e variaveis sao obrigatorios!")
  if (!is.null(palpite) && length(palpite) > 1)
    stop("informe o palpite desta forma: palpite=\"b0=1, b1=3, ... \"")
  if(F %in% grepl("\\w", variaveis, perl =T))
    stop("variaveis invalidas")
  if(is.null(palpite))
    palpite = ""

  formula = preparaFormula(formula)

  st = paste0("\"", variaveis[1], "\"")
  st2 = paste0("\", ", variaveis[1], ", \"")
  str = paste0(variaveis[[1]], "=NULL")
  str1 = variaveis[1]
  str2 = paste0("is.null(", variaveis[1], ")")
  if (2 <= length(variaveis))
    for (i in 2:length(variaveis)) {
      st = paste0(st, ",\"", variaveis[i], "\"")
      st2 = paste0(st2, ", \", ", variaveis[i], ", \"")
      str = paste0(str, ",", variaveis[i], "=NULL")
      str1 = paste0(str1, ",", variaveis[i])
      str2 = paste0(str2, " || is.null(", variaveis[i],
                    ")")
    }
  pp = ""
  pp2 = ""
  pp3 = ""
  if (!is.null(palpite)) {
    str = paste0(str, ", palpite=c(", palpite, ")")
    pp = paste0(", palpite=c(", palpite, ")")
    pp2 = ", start=', pp, '"
    pp3 = "pp = ''\n    if (!is.null(palpite) && (1 <= length(palpite))){\n    pp = 'c('\n    for (i in 1:length(palpite)) \n    pp = paste0(pp, names(palpite)[[i]], '=', palpite[[i]], ', ')\n    pp = gsub(', $', ')', pp, perl = T)\n    }\n    "
  }
  require = ""
  if (!is.null(requires)) {
    if (1 <= length(requires))
      for (i in 1:length(requires)) require = paste0(require,
                                                     "require(", requires[i], ")\n ")
  }
  if (is.null(maisParametros))
    maisParametros = ""
  else maisParametros = paste0(", ", maisParametros)
  formula2 = paste0(gsub("y2~y1", "y2,'~',y1,'", formula, ignore.case = T),
                    "'")
  if (1 <= length(variaveis))
    for (i in 1:length(variaveis)) formula2 = gsub(variaveis[i],
                                                   paste0("\\\",", variaveis[i], ",\\\""), formula2)
  formula3 = paste0("formula = gsub('", variaveis[1], "', ",
                    variaveis[1], ",formula) \n ")
  if (2 <= length(variaveis))
    for (i in 2:length(variaveis)) formula3 = paste0(formula3,
                                                     "formula = gsub('", variaveis[i], "', ", variaveis[i],
                                                     ",formula) \n ")
  modelo = NULL
  modelogenerico = paste0("modelo <- function(", str, "){\n ",
                          "nome=\"", nome, "\"\n ", "formula=\"", formula, "\"\n ",
                          "if(", str2, ") return (c( nome , formula, ", st, "))\n ",
                          "modelo=NULL\n ", formula3, "eval(parse(text = paste0(\"modelo <- function(y1=NULL, y2=NULL, base=NULL",
                          pp, "){\n    'mapeamento{(", str1, ")=(", st2, ")}'\n    ",
                          require, pp3, "if (is.null(y1) || is.null(y2) || is.null(base)) \n    return (c('\", nome, \"','\", formula, \"')) else ",
                          "return (eval(parse(text=paste0('", funcaoRegressao,
                          "(', ", formula2, ", ', data=base", pp2, maisParametros,
                          ")'))))\n}\"\n              )))\n return (modelo)\n}")
  eval(parse(text = modelogenerico))
  return(modelo)}