R/getGroups.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"getGroups" <-
  function (m, modeldiffs, labels) 
  {
    thresh <- if (length(modeldiffs$thresh) == 0) 0 else modeldiffs$thresh
    linkclp <- rep(1, length(m))
    sl <- m[[1]]@clpType 
    
    allsl <- datasetind <- clplongind <- vector()
    for (i in 1:length(m)) {
      allsl <- append(allsl, slot(m[[i]], sl))
      datasetind <- append(datasetind, rep(i, length(slot(m[[i]], sl))))
      clplongind <- append(clplongind, 1:length(slot(m[[i]], sl)))
    }
    
    if (length(allsl) < 2) 
      return(list(list(c(1, labels[1]))))
    sort_tmp <- sort(allsl, index.return = TRUE)
    sortclp <- sort_tmp$x
    sortindex <- sort_tmp$ix
    markclp <- sortclp[1]
    groups <- list(list(c(clplongind[sortindex[1]],
                          labels[datasetind[sortindex[1]]])))
    refgroup <- linkclp[datasetind[sortindex[1]]]
    for (i in 2:length(sortclp)) {
      overlimit  <- abs(markclp - sortclp[i]) > thresh 
      if (refgroup != linkclp[datasetind[sortindex[i]]] || overlimit) {
        groups[[length(groups) + 1]] <- list(c(clplongind[sortindex[i]] , 
                                               labels[ datasetind[sortindex[i]]]))
        refgroup <- linkclp[datasetind[sortindex[i]]]
        markclp <- sortclp[i]
      }
      else groups[[length(groups)]][[length(groups[[length(groups)]]) + 
                                       1]] <- c( clplongind[sortindex[i]], labels[datasetind[sortindex[i]] ])
    }
    
    groups
  }