R/fitModel.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"fitModel" <-
  function(data, modspec = list(), datasetind = vector(), modeldiffs = list(),
           opt = opt(), lprogress = FALSE) {
    currModel <- getModel(data, modspec, modeldiffs, datasetind, opt)
    globalEnvir <- as.environment(1)

    tr <- getTheta(currModel)
    theta <- tr$theta

    currModel <- tr$mod
    if (currModel@modelspec[[1]]@lscalpar) {
      thetascal <- currModel@modellist[[1]]@thetascal
      currTheta <- getThetaCl(theta * thetascal, currModel)
    } else {
      currTheta <- getThetaCl(theta, currModel)
    }

    iter <- opt@iter

    assign(".currTheta", currTheta, envir = globalEnvir)
    assign(".currModel", currModel, envir = globalEnvir)

    if (opt@algorithm == "nls") {
      if (lprogress) {
        nlsprogress <- capture.output(
          currModel@fit@nlsres$onls <- nls(~ rescomp(theta = t, d = d, currModel = currModel),
            data = list(d = vector(), currModel = currModel),
            control =
              nls.control(
                maxiter = iter,
                minFactor = opt@minFactor,
                warnOnly = TRUE,
                printEval = FALSE
              ),
            start = list(t = theta),
            algorithm = opt@nlsalgorithm,
            trace = TRUE
          )
        )
      } else {
        currModel@fit@nlsres$onls <- nls(~ rescomp(theta = t, d = d, currModel = currModel),
          data = list(d = vector(), currModel = currModel),
          control =
            nls.control(
              maxiter = iter,
              minFactor = opt@minFactor,
              warnOnly = TRUE,
              printEval = TRUE
            ),
          start = list(t = theta),
          algorithm = opt@nlsalgorithm,
          trace = TRUE
        )
      }
    } else if (opt@algorithm == "nls.lm") {
      if (length(opt@parscale) != 0) {
        if (opt@parscale[1] == "abs") {
          parscale <- 1 / abs(theta)
        } else {
          parscale <- opt@parscale
        }
        currModel@fit@nlsres$onls <- nls.lm(
          par = theta, fn = rescomp,
          currModel = currModel,
          control = list(
            nprint = 1,
            maxiter = iter, maxfev = opt@maxfev,
            diag = parscale
          )
        )
      } else {
        currModel@fit@nlsres$onls <- nls.lm(
          par = theta, fn = rescomp,
          currModel = currModel,
          control = list(
            nprint = 1,
            maxiter = iter, maxfev = opt@maxfev
          )
        )
      }
    } else if (opt@algorithm == "optim") {
      currModel@fit@nlsres$onls <- optim(
        par = theta, fn = rescomp,
        currModel = currModel,
        method = opt@optimmethod,
        control = list(
          trace = 100,
          maxit = iter
        ),
        hessian = TRUE
      )
    }
    currModel@finished <- TRUE
    if (opt@algorithm == "nls") {
      resFinal <- rescomp(
        theta = currModel@fit@nlsres$onls$m$getPars(),
        currModel = currModel
      )
    } else {
      resFinal <- rescomp(theta = currModel@fit@nlsres$onls$par, currModel = currModel)
    }

    currModel <- resFinal$currModel
    currTheta <- resFinal$currTheta

    assign(".currTheta", currTheta, envir = globalEnvir)
    assign(".currModel", currModel, envir = globalEnvir)

    if (opt@plot) {
      plotter(currModel@modellist[[1]], currModel, currTheta, opt)
    }

    currModel@optlist[[1]] <- opt

    if (lprogress) {
      ret <- list(currModel = currModel, currTheta = currTheta, nlsprogress = nlsprogress)
    } else {
      ret <- list(currModel = currModel, currTheta = currTheta)
    }

    return(ret)
  }