R/initOneModel.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"initOneModel" <-
  # Initializes some fields of the model class, calls the generic method initModelClass which depends on mod_type
  function (model) 
  {
    model@weight <- length(model@weightpar) != 0
    model@lclp0 <- length(model@clp0) != 0
    model@lclpequ <- length(model@clpequspec) != 0
    model <- initModelClass(model)    
    if(length(model@clp0) != 0) 
      model@usecompnames0 <- is.character(unlist(lapply(model@clp0, 
                                                        function(x){x[["comp"]]} ))) 
    if(length(model@clpequspec) != 0) 
      model@usecompnamesequ <- is.character(unlist(lapply(model@clpequspec, 
                                                          function(x){x[["to"]]} ))) 
    if(model@usecompnames0 || model@usecompnamesequ) {
      if(length(model@compnames) < model@ncomp) {
        model@compnames <- append(model@compnames, 
                                  1:(model@ncomp-length(model@compnames)))
      }
      if(length(model@compnames > model@ncomp))
        cat(paste("WARNING: too many component names, last", 
                  model@compnames-model@ncomp, "names not used\n"))
    }
    if(length(model@autoclp0) > 0){
      model@clp0 <- getAutoClp0(model)
      model@autoclp0 <- list() ## don't want to store the old result
    }
    if(model@mod_type=="kin") {
      if(model@irffun=="doublegaus") {
        model@doublegaus <- TRUE
      }
      if(model@irffun=="multiplegaus") {
        model@multiplegaus <- TRUE
      }
      if(model@dispmu && length(model@parmu[[1]])>0 && length(model@lambdac)==0){
        warning(sprintf("model@dispmu = %s but lamdac not specified!",model@dispmu))
      }
    }
    model@clpCon <- getClpConstr(
      if (model@clpType == "x")
        clp = model@x else clp = model@x2,
      clp0 = model@clp0, 
      clpequspec = model@clpequspec, 
      ncomp = model@ncomp, 
      compnames = model@compnames)
    model@x <- model@x * model@scalx
    model@fvecind <- getFixed(model)
    model@pvecind <- getPrel(model)
    model@mvecind <- model@nvecind <- getMvec(model)	
    model <- getConstrained(model)
    model <- addPrel(model)
    model
  }