R/getKinConcen.R

In TIMP: Fitting Separable Nonlinear Models in Spectroscopy and Microscopy

"getKinConcen" <- function (group, multimodel, thetalist, 
                            clpindepX=vector(), finished=FALSE,
                            doConstr=TRUE, oneDS = 0,
                            weight=TRUE,lreturnA=FALSE,lreturnC=FALSE) 
{
  psi <- vector()
  concen <- matrix()
  if (finished)
    rlist <- list(irfvec=vector("list",length(group)))
  Xlist <- list()
  for (i in 1:length(group)) {
    
    m <- multimodel@modellist[[group[[i]][2]]]
    t <- thetalist[[group[[i]][2]]]
    psi <- append(psi, m@psi.weight[, group[[i]][1]])
    if (m@wavedep || length(clpindepX) < 1 ) {
      irfvec <- irfparF(t@irfpar, m@lambdac, m@x2[group[[i]][1]], 
                        group[[i]][1], m@dispmu, t@parmu[[1]], m@disptau, 
                        t@partau, m@dispmufun, m@disptaufun, m@doublegaus, m@multiplegaus)
      if (length(m@cohspec) != 0) {
        if (m@cohspec$type == "freeirfdisp") 
          cohirf <- irfparF(t@irfpar, m@lambdac,
                            m@x2[group[[i]][1]], group[[i]][1],
                            m@dispmu,
                            t@parmu[[2]], m@disptau, t@partau,
                            m@dispmufun,
                            m@disptaufun, m@doublegaus, m@multiplegaus)
        else cohirf <- vector()
      }
      if(m@getX && oneDS == 0) 
        concen_i <- clpindepX[[group[[i]][2]]]
      else
        concen_i <- compModel(k = t@kinpar, 
                              kinscal = t@kinscal, x = m@x, irfpar = irfvec, 
                              irf = m@irf, seqmod = m@seqmod, fullk = m@fullk, 
                              kmat = m@kmat, jvec = t@jvec,
                              shiftmea =  t@parmu, 
                              dscalspec = m@dscalspec, 
                              drel = t@drel, cohspec = m@cohspec, oscspec = m@oscspec, oscpar = t@oscpar, coh = t@coh, 
                              cohirf = cohirf, lamb = group[[i]][1], 
                              dataset = group[[i]][2], irffun=m@irffun,
                              mirf = m@mirf, measured_irf = m@measured_irf, 
                              convalg = m@convalg, speckin2 = m@speckin2, 
                              usekin2 = m@usekin2, kinpar2 = t@kinpar2, 
                              kin2scal = t@kin2scal, reftau = m@reftau, 
                              anispec = m@anispec, anipar = t@anipar, 
                              cohcol = m@cohcol, amplitudes = t@amplitudes, 
                              streakT = m@streakT, streak=m@streak, 
                              doublegaus = m@doublegaus, multiplegaus = m@multiplegaus, fixedkmat=m@fixedkmat,
                              kinscalspecial = t@kinscalspecial,
                              kinscalspecialspec = m@kinscalspecialspec,
                              lightregimespec = m@lightregimespec
                              ,numericalintegration = m@numericalintegration,
                              initialvals = m@initialvals,
                              reactantstoichiometrymatrix
                              = m@reactantstoichiometrymatrix,
                              stoichiometrymatrix = m@stoichiometrymatrix,lreturnA=lreturnA)
      if (lreturnA||lreturnC)
        return(concen_i)
      else
      {if (m@weight && weight) 
        concen_i <- weightNL(concen_i, m, group[[i]][1])}
      if(m@getXsuper) 
        Xlist[[i]] <- concen_i	
      else {  
        concen <- if (!identical(concen, matrix())) 
          rbind(concen, concen_i)
        else concen_i
      } 
    }
    else {
      if (identical(concen, matrix())) 
        concen <- clpindepX[[group[[i]][2]]]
      else concen <- rbind(concen, clpindepX[[group[[i]][2]]])
    }
    if (finished) {
      if(m@wavedep) 
        rlist$irfvec[[i]] <- irfvec
      else rlist$irfvec[[i]] <- c(0,0)
      if (length(m@cohspec$type) != 0) {
        if (m@cohspec$type == "freeirfdisp"){ 
          if(i == 1) rlist$cohirf <- vector("list", length(group))  
          rlist$cohirf[[i]] <- cohirf
        } 
      }
    }
    
  }
  if(doConstr) 
    concen <- doConstrSuper(concen, Xlist, multimodel, 
                            thetalist, group)
  if(oneDS > 0) {
    xst <- 1
    if(oneDS > 1) {
      for(j in 1:(oneDS-1)) 
        xst <- xst + multimodel@modellist[[ group[[j]][2] ]]@nt
      xend <- xst + multimodel@modellist[[ group[[oneDS]][2] ]]@nt - 1
    }
    else xend <- multimodel@modellist[[ group[[oneDS]][2] ]]@nt
    concen <- concen[xst:xend,]
  }
  attr(concen, "rlist") <- if(finished) rlist else list()
  attr(concen, "psi") <- psi
  concen
}