R/getConstrained.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"getConstrained" <-
  function (model) 
  {
    # model@constrainedpar is a list of lists 
    # eg
    # contrainedpar = list(list(what = "kinpar", ind = c(1), 
    # low = .3, high = NA))
    
    constrained <- model@constrained 
    ppars <- sort(intersect(slotNames(theta()), slotNames(model)))  
    cinde <- vector("list", length(ppars)) 
    for(f in 1:length(cinde)) cinde[[f]] <- vector()
    names(cinde) <- ppars 
    cindeM <- cinde2M <- cinde2 <- cinde 
    if(length(constrained) > 0) {
      for(r in 1:length(constrained)) {
        if(length(constrained[[r]]$low) > 0) { 
          if(length(constrained[[r]]$ind) == 1)
            c1 <- constrained[[r]]$ind 
          else {
            if(constrained[[r]]$ind[1] > 1) 
              c1 <- (length(unlist(slot(model, 
                                        constrained[[r]]$what)[[1:(
                                          constrained[[r]]$ind[1] - 1)]])) + 
                       constrained[[r]]$ind[2])
            else 
              c1 <- constrained[[r]]$ind[2]
          }
          cinde[[ constrained[[r]]$what ]] <- 
            append( cinde[[ constrained[[r]]$what ]], c1)
          cindeM[[ constrained[[r]]$what ]] <- 
            append( cindeM[[ constrained[[r]]$what ]], 
                    constrained[[r]]$low)
        }
        else ## can't apply constraint from above and below 
          if(length(constrained[[r]]$high) > 0) { 
            if(length(constrained[[r]]$ind) == 1)
              c1 <- constrained[[r]]$ind 
            else {
              if(constrained[[r]]$ind[1] > 1) 
                c1 <- (length(unlist(slot(model, 
                                          constrained[[r]]$what)[[1:(
                                            constrained[[r]]$ind[1] - 1)]])) + 
                         constrained[[r]]$ind[2])
              else 
                c1 <- constrained[[r]]$ind[2]
              
            }
            cinde2[[ constrained[[r]]$what ]] <- 
              append( cinde2[[ constrained[[r]]$what ]], c1)
            cinde2M[[ constrained[[r]]$what ]] <- 
              append( cinde2M[[ constrained[[r]]$what ]], 
                      constrained[[r]]$high)
          }
      }
    }
    model@clinde <- cinde
    model@chinde <- cinde2
    model@lowcon <- cindeM
    model@highcon <- cinde2M
    model
  }