R/getFixed.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"getFixed" <-
  function (model) 
  {
    
    # model@fixed is a list of lists 
    # eg
    # fixed = list(kinpar = list( c(1,2), c(2,3)), irfpar = list(1,2)) 
    # get the fixed parameters indices as vector indices 
    # into the unlisted parameter vector 
    
    fixed <- model@fixed 
    free <- model@free
    ppars <- sort(intersect(slotNames(theta()), slotNames(model)))  
    finde <- vector("list", length(ppars)) 
    for(f in 1:length(finde)) finde[[f]]<-vector()
    names(finde) <- ppars 
    if(length(fixed) > 0) {
      for(r in 1:length(fixed)) {
        if(!is.list(fixed[[r]])){ 
          finde[[ names(fixed)[r] ]] <- as.vector(fixed[[r]]) 
        }
        else {
          for(s in 1:length(fixed[[r]])) {
            indf <- fixed[[r]][[s]][2]
            if(fixed[[r]][[s]][1] > 1){
              slW<-slot(model, names(fixed[r]))
              indf <- indf + sum(unlist(lapply(slW, length))[1:(fixed[[r]][[s]][1]-1)]) 
            }
            finde[[ names(fixed[r]) ]] <-
              append(finde[[ names(fixed[r]) ]], indf)
            
          }
        }
      }
    }
    
    if(length(free) > 0) {
      for(f in 1:length(finde)) finde[[f]]<-vector()
      for(r in 1:length(ppars)) 
        if(length(slot(model, ppars[r])) > 0)
          finde[[ ppars[r] ]] <- 1:length(unlist(slot(model, ppars[r])))
      if(length(free$none) == 0) {
        for(r in 1:length(free)) {
          if(!is.list(free[[r]])){ 
            finde[[ names(free)[r] ]] <- finde[[names(free)[r]]][- 
                                                                   which( finde[[ names(free)[r]]] %in% free[[r]] )]
          }
          else 
            for(s in 1:length(free[[r]])) {
              
              indf <- free[[r]][[s]][2]
              if(free[[r]][[s]][1] > 1){
                slW<-slot(model, names(free[r]))
                indf <- indf + sum(unlist(lapply(slW, length))[1:(free[[r]][[s]][1]-1)]) 
              }
              
              finde[[ names(free)[r] ]] <- finde[[names(free)[r]]][- 
                                                                     which( finde[[ names(free)[r]]] %in% indf)]
            }
        }
      }
    }
    finde
    
  }