R/getXsuper.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"getXsuper" <-
  function(Xlist, m, t, group) {
    rowLim <- unlist(lapply(Xlist, nrow))
    colLim <- unlist(lapply(Xlist, ncol))
    superX <- matrix(0, sum(rowLim), sum(colLim))
    ## fill in a superX matrix
    for (i in 1:length(group)) {
      rLim <- if (i == 1) 0 else sum(rowLim[1:(i - 1)])
      cLim <- if (i == 1) 0 else sum(colLim[1:(i - 1)])
      superX[
        (rLim + 1):(rLim + rowLim[i]),
        (cLim + 1):(cLim + colLim[i])
      ] <- Xlist[[i]]
      colnames(superX[
        (rLim + 1):(rLim + rowLim[i]),
        (cLim + 1):(cLim + colLim[i])
      ]) <- colnames(Xlist[[i]])
    }
    ## the below adds the constraints to equality based on column labels
    usednames <- vector()
    cnm <- colnames(superX)
    for (i in 1:length(cnm)) {
      nm <- cnm[i]
      if (!nm %in% usednames) {
        usednames <- append(usednames, nm)
        nm_c <- which(colnames(superX) == nm)
        superX[, i] <- apply(superX[, nm_c], 1, sum)
        superX <- superX[, -nm_c[-1]]
      }
    }
    superX
  }