R/gjamHfunctions.R

In gjam: Generalized Joint Attribute Modeling

# TOF


errorBars <- function( x0, y0, y1, col = 'grey', lwd = 2, 
                       angle = 90, code = 1, length = .2 ){
  
  ww <- which( y1 > y0 )
  if(length(ww) == 0)return()
  
  suppressWarnings(
    arrows( x0[ww], y0[ww], x0[ww], y1[ww], angle = angle, 
            code = code, lwd = lwd, col = col, length = length)
  )
}

sums2meanSd <- function( a, a2, n){
  
  # mean and sd from moments based on n values
  mu <- a/n
  aa <- pmax( a2/n - mu^2, 0 )
  sd <- sqrt( aa )
  list( mean = mu, sd = sd )
}

gjamConditionalParameters <- function( output, conditionOn, nsim = 2000 ){
  
  # output - class gjam
  # conditionOn - responses (column names in ydata) to condition on
  
  conditionOn <- .cleanNames( conditionOn )

  ynames <- colnames( output$inputs$y )
  yNot   <- ynames[ !ynames %in% conditionOn ]
  sigma  <- output$parameters$sigMu
  beta   <- output$parameters$betaMu
  
  if( 'timeList' %in% names(output$inputs))
    stop(' conditional parameters not implemented for time series')
  if( is.null(beta) )stop('conditional parameters require a beta matrix')
  
  beta[ is.na(beta) ] <- 0
  xnames <- rownames(beta)
  
  Q <- nrow(beta)
  
  REDUCT <- F
  if( 'REDUCT' %in% names(output$modelList) ){
    if( output$modelList$REDUCT )REDUCT <- T
  }
  if( REDUCT ){
    REDUCT <- T
    otherpar <- output$modelList$reductList$otherpar
    N  <- otherpar$N
    r  <- otherpar$r
  }
  
  fac <- function(sigma, beta){
    A <- sigma[yNot, conditionOn]%*%solveRcpp(sigma[drop=F,conditionOn,conditionOn])
    C <- beta[drop=F, , yNot] - beta[drop=F, , conditionOn]%*%t(A)
    P <- sigma[yNot,yNot] - A%*%sigma[drop=F,conditionOn, yNot]
    S <- 
    list(A = A, C = t(C), P = P)
  }
  
  acp <- fac(sigma, beta)
  A   <- acp$A
  C   <- acp$C
  P   <- acp$P
  
  S <- length(ynames)
  sindex <- c(1:S)
  bchain <- output$chains$bgibbsUn
  schain <- output$chains$sgibbs
  echain <- output$chains$sigErrGibbs
  
  burnin <- output$modelList$burnin
  ng     <- output$modelList$ng
  
  g  <- sample(burnin:ng, nsim, replace=T)
  nn <- length(yNot)
  nc <- length(conditionOn)
  ag <- matrix( NA, nsim, nc*nn)
  cg <- matrix( NA, nsim, Q*nn)
  pg <- matrix( NA, nsim, nn*nn)
  
  colnames(ag) <- .multivarChainNames(rownames(A),colnames(A))
  colnames(cg) <- .multivarChainNames(rownames(C),colnames(C))
  colnames(pg) <- .multivarChainNames(rownames(P),colnames(P))
  
  tmp <- .multivarChainNames2matrix( chainNames = colnames(bchain), dimnames(beta) )
  wB  <- tmp$wB
  bi  <- tmp$beta
  
  m <- 0
  
  for( i in g ){
    
    m <- m + 1
    
    bi[wB] <- bchain[i,]
    
    if(REDUCT){
      sigmaerror <- output$chains$sigErrGibbs[i]
      Z  <- matrix(output$chains$sgibbs[i,],N,r)
      K  <- output$chains$kgibbs[i,]
      si <- .expandSigma(sigmaerror, S, Z = Z, K, REDUCT = T)
    } else {
      si <- .expandSigma(schain[i,], S = S, REDUCT = F)[sindex,sindex]
    }
    colnames(bi) <- rownames(si) <- colnames(si) <- ynames
    rownames(bi) <- xnames
    tmp <- fac( si, bi )
    ag[m, ] <- tmp$A
    cg[m, ] <- tmp$C
    pg[m, ] <- tmp$P
  }
  
  atab <- .chain2tab(ag, snames = conditionOn, xnn = yNot, sigfig = 4 ) 
  ctab <- .chain2tab(cg, snames = xnames, xnn = yNot, sigfig = 4) 
  ptab <- .chain2tab(pg, snames = yNot, xnn = yNot, sigfig = 4) 
  
  list( Amu = atab$mu, Ase = atab$se, Atab = atab$tab,
        Cmu = ctab$mu, Cse = ctab$se, Ctab = ctab$tab,
        Pmu = ptab$mu, Pse = ptab$se, Ptab = ptab$tab )
}


.aggData <- function(cnames, data, gather, FUN){
  
  #cnames - column names in data to operate on
  #gather   - list of indices, all of same length
  
  cnames <- cnames[cnames %in% colnames(data)]
  if(length(cnames) == 0)return( list(data = numeric(0)) )
  
  FAC <- F
  df <- data[,cnames]
  
  if(FUN == 'factor'){
    FAC <- T
    tf <- fnames <- character(0)
    df <- numeric(0)
    
    for(j in 1:length(cnames)){
      kf <- as.character(data[,cnames[j]])
      tf <- cbind(tf, kf)
      fnames <- append(fnames,list(sort(unique(kf))))
      df <- cbind(df, match(kf,fnames[[j]]) )
    }
    colnames(df) <- cnames
    FUN <- 'max'
  }
  
  tmp <- aggregate(df, by=gather, FUN=FUN)
  ord <- do.call(order,list(tmp[,names(gather)]))
  colnames(tmp)[-c(1:length(gather))] <- cnames
  
  if(FAC){
    for(j in 1:length(cnames)){
      kf <- fnames[[j]][tmp[,cnames[j]]]
      tmp[,cnames[j]] <- as.factor(kf)
    }
  }
  list(ord = ord, data = tmp[ord,])
}

.setLoHi <- function(plist, pmat, xnames, ynames){
  
  # called by gjamPriorTemplate
  
  pnames <- names(plist)
  
  wx <- which(pnames %in% xnames)
  for(k in wx)pmat[pnames[k],] <- plist[[k]]
  
  wy <- which(pnames %in% ynames)
  for(k in wy)pmat[,pnames[k]] <- plist[[k]]
  
  comb <- grep('_',pnames)       # combination of x, y
  
  for(k in comb){
    ck <- unlist( strsplit(pnames[k],'_') )
    ik <- 1; jk <- 2
    wx <- which(xnames == ck[ik])
    if(length(wx) == 0){
      ik <- 2; jk <- 1
      wx <- which(xnames == ck[ik])
    }
    wy <- which(ynames == ck[jk])
    pmat[wx,wy] <- plist[[comb[k]]]
  }
  pmat
}

.myBoxPlot <- function(mat, tnam, snames, specColor, label, LEG=F){
  
  # tnam is columns of mat, with values of snames used to match specColor
  
  ord <- order(colMeans(mat),decreasing=F)
  mat  <- mat[,ord]
  tnam <- tnam[ord]
  bb   <- specColor[ match(tnam, snames) ]
  ry   <- quantile(mat, c(.01, .99))
  ymin <- quantile(mat, .01) - diff(ry)*.15
  ymax <- quantile(mat, .99) + diff(ry)*.7
  bx   <- .getColor(bb,.4)
  
  tmp <- .boxplotQuant( mat, xaxt='n',outline=F,ylim=c(ymin,ymax),
                        col=bx, border=bb, lty=1)
  abline(h=0,lwd=2,col='grey',lty=2)
  
  dy <- .05*diff(par()$yaxp[1:2])
  
  cext <- .fitText2Fig(tnam,fraction=1)
  text((1:length(ord)) - .1,dy + tmp$stats[5,],tnam,srt=70,pos=4,
       col=bb, cex=cext)
  
  pl    <- par('usr')
  xtext <- pl[1]
  ytext <- pl[3] + diff(pl[3:4])*.85
  .plotLabel(label,location='topleft', cex=1.0)
  
  lg <- unique(names(bb))
  if(!is.null(lg) & LEG){
    colb <- bb[lg]
    legend('bottomright',legend=lg,text.col=colb,bty='n')
  }
    
}

.splitNames <- function(nameVec, snames=NULL, split='_'){
  
  vnam <- matrix( unlist( strsplit(nameVec,split) ),ncol=2,byrow=T)
  
  if(is.null(snames))return( list(vnam = vnam, xnam = NULL) )
  
  ix <- 1
  nc <- 2
  y1 <- which(vnam[,1] %in% snames)
  y2 <- which(vnam[,2] %in% snames)
  if(length(y1) > length(y2))ix <- 2
  if(ix == 2)nc <- 1
  
  xnam <- vnam[,ix]
  vnam <- vnam[,nc]
  list(vnam = vnam, xnam = xnam)
}

.updateBetaMet <- function(X, Y, B, lo, hi, loc, REDUCT, sig=NULL,
                           sinv=NULL, sp=.01 ){
  
  # metropolis update with TIME
  
  bnew <- B
  mnow <- X%*%B
  bnew[loc] <- .tnorm(nrow(loc),lo[loc],hi[loc],B[loc],sp)
  mnew <- X%*%bnew
  
  if(REDUCT){
    pnow <-  colSums( dnorm(Y,mnow,sqrt(sig),log=T) ) #cond ind species
    pnew <-  colSums( dnorm(Y,mnew,sqrt(sig),log=T) )
    z <- which( runif(length(pnow),0,1) < exp(pnew - pnow) )
    if(length(z) > 0)B[,z] <- bnew[,z]
  }else{
    pnow <- sum( .dMVN(Y,mnow,sinv=sinv,log=T) )
    pnew <- sum( .dMVN(Y,mnew,sinv=sinv,log=T) )
    z <- runif(1,0,1) < exp(pnew - pnow) 
    if(z)B <- bnew
  }
  B
}

.getPattern <- function(mat, wloc){
  
  # finite values in mat will be idenified
  # wloc are locations in mat
  
  mat <- mat*0 + NA
  mat[ wloc ] <- 0
  
  rows <- numeric(0)
  pattern <- numeric(0)
  aa   <- mat*0
  aa[wloc] <- 1             # indicate keepers
  
  U  <- nrow(mat)
  SS <- ncol(mat)
  cc <- 1:U
  
  wk <- which( rowSums(abs(mat+1), na.rm=T) == 0 )  # rows with none to sample
  if(length(wk) > 0){
    aa[cc[wk],] <- NA
    cc <- cc[-wk]
  }
  
  if(length(cc) == 0)return( list(rows = rows, pattern = pattern) )
    
  for(k in 1:U){
    
    if(length(cc) == 0)break
    
    ak <- aa[drop=F,cc,]
    ac <- matrix(ak[1,],nrow(ak),ncol(ak),byrow=T)
    ac[is.na(ac)] <- 0
    am <- ak - ac
    
    w1 <- which( duplicated(am) & rowSums(am,na.rm=T) == 0 )
    w1 <- c(1,w1)
    
    cw <- cc[w1]
    
    rr <- matrix( cw, 1 )
    pp <- matrix( which(aa[rr[1],] != 0), 1) #length-0 means all have no prior
    if(length(pp) == 0)pp <- matrix(1:SS,1)
    
    aa[cw,] <- NA
    cc <- cc[-w1]
    
    if( length(rows) == 0 ){
      rows <- rr
      pattern <- pp
      next
    } else {
      if( ncol(rr) == ncol(rows) )rows <- rbind(rows,rr)
      if( ncol(rr) > ncol(rows) ){
        rk <- matrix(NA,nrow(rows),ncol(rr))
        rk[,1:ncol(rows)] <- rows
        rows <- rbind(rk,rr)
      }
      if( ncol(rows) > ncol(rr) ){
        rj <- matrix(NA,1,ncol(rows))
        rj[1:length(rr)] <- rr
        rows <- rbind(rows,rj)
      }
        
      if( ncol(pp) == ncol(pattern) )pattern <- rbind(pattern,pp)
      if( ncol(pp) > ncol(pattern) ){
        rk <- matrix(NA,nrow(pattern),ncol(pp))
        rk[,1:ncol(pattern)] <- pattern
        pattern <- rbind(rk,pp)
      }
      if( ncol(pattern) > ncol(pp) ){
        rj <- matrix(NA,1,ncol(pattern))
        rj[1:length(pp)] <- pp
        pattern <- rbind(pattern,rj)
      }
    }
    
    if(length(cc) == 0)break
  }
  
  list(rows = rows, pattern = pattern)
}

.alphaPrior <- function(ww, tindex, ap, notOther){
  
  S <- ncol(ww)
  lo <- ap$lo
  hi <- ap$hi
  
  al <- (lo + hi)/2
  al[ lo == hi ] <- NA
  
  tmp    <- .getURowCol( mat = al, notOther )
  uindex <- tmp$uindex
  Amat   <- tmp$Amat
  wA     <- tmp$wA
  aindex <- tmp$aindex
  
  loA <- hiA <- Amat
  loA[ wA ] <- lo[ aindex[,c('toW','fromW')] ]
  hiA[ wA ] <- hi[ aindex[,c('toW','fromW')] ]
  
  list(Amat = Amat, loAmat = loA, hiAmat = hiA, 
       wA = wA, uindex = uindex, aindex = aindex)
}

.betaPrior <- function(beta, notOther, loBeta, hiBeta){
  
  BPRIOR <- F
  loB <- hiB <- NULL
  
  bg <- beta
  
  wB <- which(!is.na(t(loBeta[,notOther, drop=F])) &
                t(loBeta[,notOther, drop=F] != hiBeta[,notOther, drop=F]), arr.ind=T)[,c(2,1)]
  colnames(wB) <- c('row','col')
  bg <- bg*0
  bg[ wB ] <- -999
  zB <- which(is.na(bg) | bg != -999)
  
  bg <- (loBeta + hiBeta)/2
  bg[ is.nan(bg) ] <- 0
  
  loB <- loBeta[,notOther, drop=F]
  hiB <- hiBeta[,notOther, drop=F]
  list(beta = bg, loB = loB, hiB = hiB, wB = wB, zB = zB, BPRIOR = BPRIOR)
}

.rhoPrior <- function(lprior, w, x, tindex, xnames, 
                         snames, other, notOther, timeLast = NULL){
  
  loRho <- lprior$lo
  hiRho <- lprior$hi
  rho   <- (loRho + hiRho)/2
  
  if(length(other) > 0)loRho[,other] <- hiRho[,other] <- NA
  
  lkeep    <- which(!is.na(loRho))
  
  M  <- nrow(rho)
  rownames(rho)[1] <- 'intercept'
  S  <- ncol(rho)
  SS <- length(notOther)
  n  <- nrow(x)
  wz   <- w
  
  gindex <- kronecker(diag(S),rep(1,M)) 
  gindex <- gindex[lkeep,]
  
  wg     <- which(gindex == 1,arr.ind=T)
  wc     <- matrix(rep(1:M,S*M),S*M,S)[lkeep,]
  rowG   <- wc[wg]
  gindex <- cbind(rowG,wg)
  tmp    <- as.vector( t(outer(colnames(rho)[notOther],
                               rownames(rho),paste,sep='_') ) )
  rownames(gindex) <- tmp[lkeep]
  
  colX <- match(rownames(rho),colnames(x))
  colX <- colX[rowG]
  gindex <- cbind(colX, gindex)
  colnames(gindex)[3:4] <- c('rowL','colW')
  nV <- nrow(gindex)
  
  # Vmat is w[t-1,]*x[t,]
  Vmat <- matrix(0,n,nV)
  wz[wz < 0] <- 0
  Vmat[tindex[,1],] <- wz[tindex[,1], gindex[,'colW']]*x[tindex[,1], gindex[,'colX']]
  Vmat[timeLast,]   <- wz[timeLast, gindex[,'colW']]*x[timeLast, gindex[,'colX']]
  
  Rmat <- matrix(NA,nV,S)
  rownames(Rmat) <- rownames(gindex)
  loRmat <- hiRmat <- Rmat[,notOther]
  
  Rmat[ gindex[,c('rowL','colW')] ] <- rho[ gindex[,c('rowG','colW')] ]
  
  lo <- hi <- Rmat*0
  lo[ gindex[,c('rowL','colW')] ] <- loRho[ gindex[,c('rowG','colW')] ]
  hi[ gindex[,c('rowL','colW')] ] <- hiRho[ gindex[,c('rowG','colW')] ]
  Rmat[ is.nan(Rmat) ] <- 0
  
  wL <- which(!is.na(Rmat[,notOther]),arr.ind=T)
 # lo[is.na(lo)] <- 0
 # hi[is.na(hi)] <- 0
  
  list(Rmat = Rmat, loRmat = lo[,notOther], hiRmat = hi[,notOther], wL = wL, 
       gindex = gindex, Vmat = Vmat)
}

.plotXbyY <- function(xdata, yy, ee, vname, xlim=range(xdata[,vname],na.rm=T)){
  
  plotj <- as.character(xdata[,'plot'])
  sitej <-  .splitNames(plotj)$vnam[,1]
  sitea <- sort(unique(sitej))
  years <- sort(unique(xdata[,'year']))
  nyr   <- length(years)
  labs  <- rep(1:12,nyr)
  week  <- (1:(nyr*12))*30
  midYr <- (1:(nyr*2))*365/2
  S     <- ncol(yy)
  ynames <- colnames(yy)
  
  mfrow <- .getPlotLayout(S)
  xaxt  <- 's'
  if(vname == 'JD'){
    xaxt <- 'n'
    xlim <- c(130,365*nyr)
  }
  
  par(mfrow=mfrow,bty='n',mar=c(4,4,1,1))
  
  for(s in 1:S){
    ys <- yy[,s]/ee[,s]
    plot(NULL,xlim=xlim,ylim=range(ys,na.rm=T),xlab=' ',ylab='count/14 day/m2',
         xaxt=xaxt)
    if(vname == 'JD'){
      abline(v=midYr,col='grey',lty=2)
      axis(1,at=week,labels=labs)
    } 
    for(k in 1:length(sitea)){
      for(j in 1:nyr){
        wk <- which(sitej == sitea[k] & xdata[,'year'] == years[j])
        if(length(wk) == 0)next
        lines((j-1)*365 + xdata[wk,vname],ys[wk])
      }
    }
    title(ynames[s])
  }
}

.pasteCols <- function(mm){
  tmp <- apply(mm,1,paste0,collapse='-')
  names(tmp) <- NULL
  tmp
}
  
.getURowCol <- function(mat, notOther){
  
  # mat is S by S
  
  rownames(mat) <- colnames(mat) <- NULL
  S <- ncol(mat)
  
  ww <- which(is.finite(t(mat)),arr.ind=T)
  ww <- ww[,c(2,1)]
  colnames(ww) <- c('toW','fromW')
  wnames <- .pasteCols(ww)
  
  #unique rows/columns
  
  ar <- matrix(0,S,S)
  ar[ww] <- 1
  ar[ww[,c(2,1)]] <- 1
  wa <- which(ar == 1,arr.ind=T)
  wa <- wa[wa[,2] >= wa[,1],]
  wa <- wa[order(wa[,1],wa[,2]),]
  uindex <- wa
  
  un <- .pasteCols(wa)
  nu <- .pasteCols(wa[,c(2,1)])
  
  arow <- match(wnames,un)
  vrow <- match(wnames,nu)
  
  aindex <- ww
  
  arow[is.na(arow)] <- vrow[is.na(arow)]
  rownames(ww) <- un[arow]
  wA <- cbind(arow,ww[,1])
  colnames(wA) <- c('rowA','toW')

  Amat <- matrix(NA,nrow(uindex),S)
  Amat[wA] <- mat[ aindex[,c('toW','fromW')] ]
  rownames(Amat) <- un
  rownames(uindex) <- un
  
  wnot <- which( aindex[,1] %in% notOther & aindex[,2] %in% notOther )
  wA   <- wA[wnot,]
  aindex <- aindex[wnot,]
  
  list(uindex = uindex, Amat = Amat, wA = wA, aindex = aindex)
}

.invertCondKronecker <- function(sinv1, sinv2, cindex){
  
  # cindex - rows and columns to condition on in ns1*ns2
  # inverse of kronecker(s1,s2) = kronecker(sinv1,sinv2)
  
  ns1 <- nrow(sinv1)
  ns2 <- nrow(sinv2)
  n   <- ns1*ns2
  
  i1  <- c(1:n)[cindex]      #estimated
  i0  <- c(1:n)[-cindex]     #known
  
  #    sk  <- kronecker(s1,s2)
  ck  <- kronecker(sinv1,sinv2)
  sk  <- solveRcpp( .invertSigma(ck[i1,i1],REDUCT=F ) )
  
  sinverse <- ck[i0,i0] - ck[i0,i1]%*%sk%*%ck[i1,i0]
  sinverse
}

gjamFillMissingTimes <- function(xdata, ydata, edata, groupCol, timeCol, 
                                 groupVars = groupCol,
                                 FILLMEANS = FALSE, typeNames = NULL,
                                 missingEffort = .1){
  
  # if FILLMEANS, then typeNames must be provided; missing ydata filled with 
  #               group-species mean, and
  #               missing edata filled with group-species mean times missingEffort
  # xdata, ydata, edata - x, y, effort
  # groupCol  - column name for group variable, i.e., constant within a group
  # timeCol   - column name for time index
  # groupVars - character vector of column names having values that are fixed for a 'group', 
  #              i.e., they do not not change with time, in 'timeCol'
  # sequences currently not used
  
  # returns timeList holding indices required for fitting with gjam
  
  
  if(is.null(colnames(xdata)))stop('xdata must have column names')
  if(is.null(colnames(ydata)))stop('ydata must have column names')
  
  if(FILLMEANS & is.null(typeNames)){
    stop(" if FILLMEANS then provide typeNames as single value (e.g., 'DA') or vector for each column of ydata")
  }
  
  if(is.character(xdata[,timeCol])){
     stop( paste('the time index xdata$',timeCol, ' must be numeric', sep='') )
  }
  
  if(!is.null(groupVars))groupVars <- groupVars[ groupVars %in% colnames(xdata) ]
  
  wna <- which( is.na(edata) | edata == 0, arr.ind=T )
  if(length(wna) > 0){
    nna <- nrow(wna)
    pna <- signif( nna/length(as.vector(edata)) )
    
    me <- apply(edata, 2, quantile, .5, na.rm=T )      # modal effort
    mm <- me[ wna[,2] ]
    mm[ mm == 0 ] <- missingEffort
    
    edata[wna] <- mm*missingEffort
    print( paste( nna, ' missing values (', pna, '%) in edata', sep='') )
  }

  ord <- order(xdata[,groupCol], xdata[,timeCol])
  
  xdata <- xdata[ord, ]
  ydata <- ydata[ord, ]
  edata <- edata[ord, ]
  
  groupIndex <- xdata[,groupCol]
  if(is.factor(groupIndex))groupIndex <- as.character(groupIndex)
  allGroups  <- sort(unique(groupIndex))
  groupIndex <- match(groupIndex,allGroups)
  ngroups    <- length(allGroups)
  
  allTimes   <- sort(unique(xdata[,timeCol]))
  allTimes   <- min(xdata[,timeCol], na.rm=T):max(xdata[,timeCol], na.rm=T)
  timeIndex  <- match(xdata[,timeCol],allTimes)

  xdata     <- cbind(groupIndex,timeIndex,xdata)
  timeZero <- numeric(0)
  
  tord <- order(groupIndex, timeIndex, decreasing=F)
  
  xtmp <- xdata[tord,]
  ytmp <- as.matrix( ydata[tord,] )
  etmp <- as.matrix( edata[tord,] )
  
  timeIndex  <- xtmp[,'timeIndex']
  groupIndex <- xtmp[,'groupIndex']
  
  notFactor <- !sapply(xtmp,is.factor)
  notChar   <- !sapply(xtmp,is.character)
  notFactor <- which(notFactor & notChar)
  
  insert <- 0
  xtmp <- cbind(insert, xtmp) 
  x1 <- xtmp[drop=F, 1, ]
  y1 <- as.matrix( ytmp[drop=F, 1, ] ) + NA
  e1 <- as.matrix( etmp[drop=F, 1, ] )*0
  
  for(m in 1:ncol(x1))x1[,m] <- NA
  x1[,'insert'] <- 1
  
  xnew <- ynew <- enew <- numeric(0)
  
  for(j in 1:ngroups){
    
    wj <- which(xtmp$groupIndex == j)
    
    mj <- range(xtmp[wj,timeCol], na.rm=T)
    nr <- diff(mj) + 2
    jt <- (mj[1]-1):mj[2]
    tt <- c(1:nr) - 1
    
    #xdata
    xj <- x1
    if(!is.null(groupVars)){
      groupVars <- groupVars[ groupVars %in% colnames(xtmp) ]
      if(length(groupVars) > 0)xj[,groupVars] <- xtmp[wj[1],groupVars]
    }
    
    xj <- xj[rep(1, nr),]
    xj[,timeCol] <- jt
    xj[,'timeIndex'] <- tt
    
    mm <- match(xtmp[wj,timeCol], xj[,timeCol]) 
    xj[mm,] <- xtmp[wj,]
    xj[,'timeIndex'] <- tt
    xj[,'groupIndex'] <- j
    
    xj[mm,'insert'] <- 0
    
    #ydata
    yj <- y1[rep(1, nr),]
    yj[mm,] <- ytmp[wj,]
    
    #edata
    ej <- e1[rep(1, nr),]
    ej[mm,] <- etmp[wj,]
    
    xnew <- rbind(xnew, xj)
    ynew <- rbind(ynew, yj)
    enew <- rbind(enew, ej)
  }
    
  rn <- columnPaste(xnew[,'groupIndex'],xnew[,'timeIndex'])
    
  rownames(xnew) <- rownames(ynew) <- rownames(enew) <- rn
  
  timeZero <- which(xnew[,'timeIndex'] == 0)
  timeLast <- timeZero[-1] - 1
  timeLast <- c(timeLast,nrow(xnew))
  
  colnames(xnew)[colnames(xnew) == 'groupIndex'] <- 'groups'
  colnames(xnew)[colnames(xnew) == 'timeIndex'] <- 'times'
  
  noEffort <- which(rowSums(etmp,na.rm=T) == 0)
  noEffort <- noEffort[!noEffort %in% timeZero]
  
  rowInserts <- which(xnew[,'insert'] == 1)
  
  
  ymiss <- which( is.na(ynew), arr.ind=T )
  
  if(FILLMEANS){
    
    if(length(typeNames) == 1)typeNames <- rep(typeNames, ncol(ynew))
    
    sl <- rep(colnames(ynew), each = nrow(ynew))
    gl <- rep(xnew[,'groups'], nrow(ynew))
    ym <- tapply(ynew, list(group = rep(xnew[,'groups'], ncol(ynew)),
                            species = sl),
                 mean, na.rm=T)
    if(!is.matrix(ym)){
      ym <- t( as.matrix(ym) )
      rownames(ym) <- xnew[1,'groups']
    }
    ym <- ym[drop=FALSE,,colnames(ynew)]
    rym <- round( ym[drop=FALSE, ,typeNames %in% c('DA','PA','CC')] )
    
    ym[,typeNames %in% c('DA','PA','CC')] <- rym
      
    rr <- match( xnew[ ymiss[,1],'groups'], rownames(ym) )
    cc <- match( colnames(ynew)[ymiss[,2]], colnames(ym) )
    
    ynew[ ymiss ]    <- ym[ cbind(rr, cc) ]
    
    ynew[timeZero, ] <- ynew[timeZero + 1, ]
    ynew[ ymiss ] <- ynew[ ymiss ]*missingEffort
    
    ynew[,typeNames %in% c('DA','PA','CC')] <- round( ynew[,typeNames %in% c('DA','PA','CC')] )
    sl <- rep(colnames(ynew), each = nrow(ynew))
    
    enew <- enew[,colnames(ynew)]
    
    em <- enew
    em[ em == 0 ] <- NA
    em <- tapply(as.vector(em), list(group = rep(xnew[,'groups'], ncol(enew)),
                            species = sl),
                 mean, na.rm=T)
    if(!is.matrix(em)){
      em <- t( as.matrix(em) )
      rownames(em) <- xnew[1,'groups']
    }
    
    em <- em*missingEffort
    enew[ ymiss ] <- em[ cbind(rr, cc) ]
  }
  
  timeList <- list(times = timeCol, groups = groupCol, 
                   timeZero = timeZero, timeLast = timeLast,
                   rowInserts = rowInserts, noEffort = noEffort)
  
  list(xdata = xnew, ydata = as.matrix(ynew), edata = enew, 
       timeList = timeList)
}

.traitTables <- function(specs, traitTab, groups, types='CA', fill=T){
  
  # specs    - matrix of species names, at least 2 columns,
  #            for which a specByTrait table 
  #            is needed
  # traitTab - S x M spec by trait matrix of traits
  # groups   - data frame, S rows, columns are species, genus,...
  #            columns match specs matrix
  # types    - CA and CON will be means, OC will be modes
  # if(fill), then fill missing with trait means
  
  wi       <- which( !duplicated(groups[,1]) )
  groups   <- groups[wi,]  # one row per species
  traitTab <- traitTab[wi,]
  
  for(j in 2:ncol(specs)){
    specs[,j]  <- .cleanNames(as.character(specs[,j]))
    groups[,j] <- .cleanNames(as.character(groups[,j]))
  }
  
  ng        <- ncol(groups)
  
  #species traits
  ns <- nrow(specs)
  nt <- ncol(traitTab)
  
  stt <- matrix(0,ns,nt)
  
  i  <- match(specs[,1],groups[,1])
  wi <- which(is.finite(i))
  stt[wi,] <- as.matrix( traitTab[i[wi],] )
  rownames(stt) <- specs[,1]
  colnames(stt) <- colnames(traitTab)
  
  tabList <- list(stt)
  
  for(k in 2:ng){
    
    sk0    <- tabList[[k-1]]
    kn     <- rownames(sk0)
    
    allk <- unique(specs[,k])
    ii   <- match(specs[,k],allk)
    i    <- rep( ii, nt )
    j    <- rep( 1:nt, each=ns)
    
    nall <- length(allk)
    
    mm   <- matrix(0,nall,nt)
    sk0[sk0 == 0] <- NA
    
    stk <- .byGJAM(as.vector(sk0), i, j, mm,mm, fun='mean')
    colnames(stk) <- colnames(traitTab)
    rownames(stk) <- allk
    
    stk <- stk[specs[,k],]
    stk[is.finite(sk0)] <- sk0[is.finite(sk0)]
    
    tabList <- append(tabList, list(stk))
  }
  
  traitMeans <- colMeans(traitTab,na.rm=T)
  
  if(fill){
    
    ww <- which(tabList[[ng]] == 0, arr.ind=T)
    if(length(ww) > 0){
      tabList[[ng]][ww] <- traitMeans[ww[,2]]
    }
  }
  list(traitMeans = traitMeans, traitList = tabList, 
       specs = specs)
}

.combineFacLevels <- function(xfactor,fname=NULL, aname = 'reference', 
                              vminF=1){
  tmp <- as.character(xfactor)
  tmp[tmp %in% fname] <- aname
  tab <- table(tmp)
  wm  <- names(tab)[tab < vminF]
  tmp[tmp %in% wm] <- aname
  as.factor(tmp)
}

.getColor <- function(col,trans){
  
  # trans - transparency fraction [0, 1]
  
  tmp <- col2rgb(col)
  rgb(tmp[1,], tmp[2,], tmp[3,], maxColorValue = 255, 
      alpha = 255*trans, names = paste(col,trans,sep='_'))
}
  
.figure1 <- function(){
  sig <- .9
  mu  <- 3.1
  offset <- -2
  
  par(mfrow=c(1,2),bty='n',mar=c(6,5,3,.1))
  part <- c(0,2,3.3,4.9,6.6)
  w    <- seq(-1,7,length=500)
  dw   <- dnorm(w,mu,sig)
  dp   <- dw[ findInterval(part,w) ]
  pw   <- pnorm(part,mu,sig)
  pw[-1] <- diff(pw)
  
  plot(w,2*dw - .5,type='l',ylim=c(-.5,4),yaxt='n', 
       ylab= expression(paste(italic(y),'|(',italic(w),', ',bold(p),')',sep='')), 
       xlab= expression(paste(italic(w),'|(',bold(x)[i],', ',bold(beta),
                              ', ',bold(Sigma),')',sep='')), 
       xlim=c(offset,7), lwd=2)
  axis(2, at = c(0:5))
  
  db <- .15
  int <- 4
  
  polygon( c(w,rev(w)), 2*c(dw,w*0) - .5, col='grey', lwd=2)
  
  lines(c(-1,part[1]),c(0,0),lwd=2)
  
  
  for(j in 1:(length(part))){
    
    lines( part[j:(j+1)],c(j,j), lwd=3)
    
    ww <- which(w >= part[j] & w <= part[j+1])
    
    if(j == 3){
      w1 <- ww[1]
      w2 <- max(ww)
      errorBars( mean(w[ww]), 2*max(dw[ww]) - .4, j - .4, lwd = 3, angle = 20 )
      suppressWarnings(
      arrows( w[w1] - .5 , j , -.7, j , angle= 20, 
              lwd = 3, col='grey', length=.2)
      )
      text( c(w[w1], w[w2]),c(3.3,3.3),
            expression(italic(p)[4], italic(p)[5]))
      text( w[w2] + .3,.6,expression( italic(w)[italic(is)] ))
      text( 0,3.5,expression( italic(y)[italic(is)] ))
    }
    
    coll <- 'white'
    if(j == int)coll <- 'grey'
    rect( offset, j - 1 - db, 2*pw[j] + offset, j - 1 + db, 
          col=coll, border='black', lwd=2)
  }
  
  ww <- which(w >= part[int - 1] & w <= part[int])
  abline(h = -.5, lwd = 2)
  
  title('a) Data generation',adj=0, font.main = 1, font.lab =1)
  
  plot(w,2*dw - .5,type='l',ylim=c(-.5,4), yaxt='n', 
       ylab= expression(italic(y)), 
       xlab= expression(paste(italic(w),'|(',italic(y),', ',bold(p),')',sep='')), 
       xlim=c(offset,7), lwd=2,col='grey')
  axis(2, at = c(0:5))
  
  lines(c(-1,part[1]),c(0,0),lwd=2)
  abline(h=-.5, lwd=2, col='grey')
  
  for(j in 1:(length(part))){
    
    lines( part[j:(j+1)],c(j,j), lwd=3)
    lines(part[c(j,j)],2*c(0,dp[j])-.5, col='grey')
    
    coll <- 'white'
    if(j -- int)coll <- 'grey'
    
    if(j == int){
      rect( offset, j - 1 - db, 2*pw[j] + offset, j - 1 + db,
            col='black', border='black')
    }
  }
  
  ww <- which(w >= part[int - 1] & w <= part[int])
  polygon( w[c(ww,rev(ww))], 2*c(dw[ww],ww*0) - .5, col='grey', lwd=2)
  
  errorBars( mean(w[ww]), int - 1.3, 2*max(dw) - .5, lwd = 3, angle = 20 )
  
  suppressWarnings(
    arrows( -.5,  int - 1, min(w[ww]) - .4, int - 1, angle= 20,
            lwd = 3, col='grey', length=.2)
  )
  title('b) Inference',adj=0, font.main = 1, font.lab = 1)
}

.add2matrix <- function(values,xmat=NULL){
  
  #xmat   - matrix with one row, columns are integer values
  #values - length-n vector be added/slotted in to xvec
  
  if(is.null(xmat)){
    n    <- length(values)
    cc   <- sort(unique(values))
    xmat <- matrix(0,n,length(cc),dimnames = list(1:n,cc))
    xmat[ cbind( c(1:n),match(values,cc)) ] <- 1
    return(xmat)
  }
  
  n <- nrow(xmat)
  if(length(values) != n)stop('vector length must equal rows in xmat')
  
  all <- sort( unique( c(values,as.numeric(colnames(xmat))) ))
  nc       <- length(all)
  
  xnew <- matrix(0,n,nc,dimnames = list(1:n,all))
  xnew[,colnames(xmat)] <- xmat
  
  xnew[ cbind(c(1:n),match(values,all)) ] <- xnew[ cbind(c(1:n),match(values,all)) ] + 1
  xnew
}

.appendMatrix <- function(m1,m2,fill=NA,SORT=F,asNumbers=F){  
  
  # matches matrices by column names
  # asNumbers: if column heads are numbers and SORT, then sort numerically

   if(length(m1) == 0){
     if(is.matrix(m2)){
       m3 <- m2
     } else {
       m3 <- matrix(m2,nrow=1)
     }
     if( !is.null(names(m2)) )colnames(m3) <- names(m2)
     return(m3)
   }
   if(length(m2) == 0){
     if(!is.matrix(m1))m1 <- matrix(m1,nrow=1)
     return(m1)
   }
   if( is.vector(m1) | (length(m1) > 0 & !is.matrix(m1)) ){
     nn <- names(m1)
     if(is.null(nn))warning('cannot append matrix without names')
     m1 <- matrix(m1,1)
     colnames(m1) <- nn
   }  
   if( is.vector(m2) | (length(m2) > 0 & !is.matrix(m2)) ){
     nn <- names(m2)
     if(is.null(nn))warning('cannot append matrix without names')
     m2 <- matrix(m2,1)
     colnames(m2) <- nn
   }

   c1 <- colnames(m1)
   c2 <- colnames(m2)
   r1 <- rownames(m1)
   r2 <- rownames(m2)
   n1 <- nrow(m1)
   n2 <- nrow(m2)

   allc <-  unique( c(c1,c2) ) 
   if(SORT & !asNumbers)allc <- sort(allc)
   if(SORT & asNumbers){
     ac <- as.numeric(allc)
     allc <- as.character( sort(ac) )
   }

   nr <- n1 + n2
   nc <- length(allc)

   if(is.null(r1))r1 <- paste('r',c(1:n1),sep='-')
   if(is.null(r2))r2 <- paste('r',c((n1+1):nr),sep='-')
   new <- c(r1,r2)

   mat1 <- match(c1,allc)
   mat2 <- match(c2,allc)

   out <- matrix(fill,nr,nc)
   colnames(out) <- allc
   rownames(out) <- new

   out[1:n1,mat1] <- m1
   out[(n1+1):nr,mat2] <- m2
   out
}

.byIndex <- function(xx,INDICES,FUN,coerce=F,...){  
  
  # INDICES is list, each same length as  x
  
  nl <- length(INDICES)
  
  tmp  <-  unlist(by( as.vector(xx),INDICES,FUN,...) ) 
  nd   <- dim(tmp)
  tmp  <- array(tmp,dim=nd, dimnames=dimnames(tmp))
  
  tmp[is.na(tmp)] <- 0
  
  if(!coerce)return(tmp)
  
  dname <- dimnames(tmp)
  mk    <- rep(0,length(nd))
  
  for(k in 1:length(nd))mk[k] <- max(as.numeric(dimnames(tmp)[[k]]))
  
  wk <- which(mk > nd)
  if(length(wk) > 0){
    tnew  <- array(0,dim=mk)
    if(length(dim(tnew)) == 1)tnew <- matrix(tnew,dim(tnew),1)
    for(k in wk){
      newk <- c(1:mk[k])
      mat  <- match(dimnames(tmp)[[k]],newk)
      if(k == 1){
        tnew[mat,] <- tmp
        rownames(tnew) <- 1:nrow(tnew)
      }
      if(k == 2){
        tnew[,mat] <- tmp
        colnames(tnew) <- c(1:ncol(tnew))
      }
      tmp <- tnew
    }
  }
  tmp
}

.chains2density <- function(chainMat,labs=NULL,reverseM=F,varName=NULL,
                            cut=0){
  
  #assumes column names are varName or 'something_varname'
  #chainMat - MCMC output [samples,chains]
  
  chNames <- colnames(chainMat)
  
  
  if(!is.null(varName)){
    
    wc <- grep(varName,colnames(chainMat),fixed=T)
    if(length(wc) == 0)stop('varName not found in colnames(chainMat)')
    
    ww <- grep('_',colnames(chainMat),fixed=T)
    if(length(ww) > 0){
      tmp <- .splitNames(colnames(chainMat))$vnam
      wc  <- which(tmp[,2] == varName)
      if(length(wc) == 0)wc <- which(tmp[,1] == varName)
    }
    chainMat <- chainMat[, wc, drop=F]
    if(!is.matrix(chainMat))chainMat <- matrix(chainMat,ncol=1)
    colnames(chainMat) <- chNames[wc]
  }
  
  nj <- ncol(chainMat)
  nd <- 512
  
  clab <- colnames(chainMat)
  if(is.null(labs) & !is.null(clab))labs <- clab
  if(is.null(labs) & is.null(clab)) labs <- paste('v',c(1:nj),sep='-')
  
  xt <- yt <- matrix(NA,nj,nd)
  rownames(xt) <- rownames(yt) <- labs
  
  xrange <- signif(range(chainMat),2)
  
  for(j in 1:nj){
    
    xj  <- chainMat[,j]
    tmp <- density(xj,n = nd, cut=cut, na.rm=T)
    xt[j,]  <- tmp$x
    yt[j,]  <- tmp$y
    
  }
  yymax <- max(yt,na.rm=T)
  
  if(reverseM){
    xt <- -t( apply(xt,1,rev) )
    yt <- t( apply(yt,1,rev) )
  }
  
  list(x = xt, y = yt, xrange = xrange, ymax = yymax, chainMat = chainMat)
}

.checkDesign <- function( x, intName='intercept', xflag=':', 
                         isFactor = character(0) ){  # 

  # xflag - indicates that variable is an interaction
  # isFactor - character vector of factor names returned if not supplied
  
  p <- ncol(x)
  
  if(ncol(x) < 3){
    return( list(VIF = 0, correlation = 1, rank = 2, p = 2, isFactor=isFactor) )
  }
    
  if(is.null(colnames(x))){
    colnames(x) <- paste('x',c(1:p),sep='_')
  }
  xrange      <- apply(x,2,range,na.rm=T)
  wi          <- which(xrange[1,] == 1 & xrange[2,] == 1)
  if(length(wi) > 0)colnames(x)[wi] <- 'intercept'
  
  wx <- grep(xflag,colnames(x))
  wi <- which(colnames(x) == 'intercept')
  wi <- unique(c(wi,wx))

  xname <- colnames(x)
  
  wmiss <- which(is.na(x),arr.ind=T)
  
  if(length(wmiss) > 0){
    rowTab <- table( table(wmiss[,1]) )
    colTab <- table(wmiss[,2])
  }
    
  VIF <- rep(NA,p)
  names(VIF) <- xname
  
  GETF <- F
  if(length(isFactor) > 0)GETF <- T
  
  for(k in 1:p){

    if(xname[k] %in% wi)next
    
    notk <- xname[xname != xname[k] & !xname %in% xname[wi]]
    ykk  <- x[,xname[k]]
    xkk  <- x[,notk,drop=F]
    
    wna <- which(is.na(ykk) | is.na(rowSums(xkk)))
    if(length(wna) > 0){
      ykk <- ykk[-wna]
      xkk <- xkk[-wna,]
    }
    
    ttt <- suppressWarnings( lm(ykk ~ xkk) )
    tkk <- suppressWarnings( summary(ttt)$adj.r.squared )
    VIF[k] <- 1/(1 - tkk)
    
    xu <- sort( unique(x[,k]) )
    tmp <- identical(c(0,1),xu)
    if(GETF)if(tmp)isFactor <- c(isFactor,xname[k])
  }

  VIF <- VIF[-wi] 

  corx <- cor(x[,-wi], use="complete.obs")
  if(length(wna) == 0){
    rankx <- qr(x)$rank
  } else {
    rankx <- qr(x[-wna,])$rank
  }
  corx[upper.tri(corx,diag=T)] <- NA
  
  findex <- rep(0,p)
  
  findex[xname %in% isFactor] <- 1
  
  designTable <- list('table' = rbind( round(VIF,2),findex[-wi],round(corx,2)) )
  rownames(designTable$table) <- c('VIF','factor',xname[-wi])
  
  designTable$table <- designTable$table[-3,]
  
  if(p == rankx)designTable$rank <- paste('full rank:',rankx,'= ncol(x)')
  if(p < rankx) designTable$rank <- paste('not full rank:',rankx,'< ncol(x)')

  list(VIF = round(VIF,2), correlation = round(corx,2), rank = rankx, p = p,
       isFactor = isFactor, designTable = designTable)
}

.fitText2Fig <- function(xx, width=T, fraction=1, cex.max=1){
  
  # returns cex to fit xx within fraction of the current plotting device
  # width - horizontal labels stacked vertically
  #!width - vertical labels plotted horizontally
  
  px <- par('pin')[1]
  py <- par('pin')[2]
  cl <- max( strwidth(xx, units='inches') )
  ch <- strheight(xx, units='inches')[1]*length(xx)  # ht of stacked vector
  
  if(width){              #horizontal labels stacked vertically
    xf <- fraction*px/cl
    yf <- fraction*py/ch
  } else {                #vertical labels plotted horizontally
    xf <- fraction*px/ch
    yf <- fraction*py/cl
  }
  
  cexx <- min(c(xf,yf))
  if(cexx > cex.max)cexx <- cex.max
  cexx
}

.cov2Dist <- function(sigma){ #distance induced by covariance
  
  n <- nrow(sigma)
  matrix(diag(sigma),n,n) + matrix(diag(sigma),n,n,byrow=T) - 2*sigma
}

.distanceMatrix <- function(mat, DIST=F){
  
  # mat is n by m matrix
  # if DIST, then returns a m by m distance matrix, otherwise corr matrix
  
  if(isSymmetric(mat)){
    if( all(diag(mat) == 1) ){   #now a correlation matrix
      mmm1 <- mat
      if(DIST)mmm1 <- .cov2Dist(mat)
    } else {                      #now a covariance 
      if(DIST){
        mmm1 <- .cov2Dist( mat )
      } else {
        mmm1 <- cor(mat)
      }
    }
  } else  {     # not symmetric
    if(DIST){
      mmm1 <- .cov2Dist( cov(mat) )
    } else {
      mmm1 <- cor(mat)
    }
  }
  mmm1
}

.reorderMatrix <- function(mat, DIST, opt=NULL){
  
  # row and column order based on correlation or distance
  
  mmm <- .distanceMatrix(mat, DIST)
  imm <- .distanceMatrix(t(mat), DIST)
  
  if(is.null(opt)){
    clist <- list(PLOT=F, DIST = DIST)
  }else{
    clist <- opt
    clist$PLOT <- T
  }
  
  h1   <- .clusterPlot( imm, opt = clist)
  rord <- h1$corder
  h2   <- .clusterPlot( mmm, opt = clist )
  cord <- h2$corder
  
  list(rowOrder = rord, colOrder = cord, rowTree = h1, colTree = h2)
}

.clustMat <- function(mat, SYM){
  
  mrow <- mat
  DIST <- T
  if(SYM){
    if(all(diag(mrow) == 1)){
      DIST <- F
      mrow <- cor(mat)
      if(nrow(mrow) != nrow(mat))mrow <- cor(t(mat))
    }else{
      mrow <- .cov2Dist(cov(mat))
      if(nrow(mrow) != nrow(mat))mrow <- .cov2Dist(cov(t(mat)))
    }
  }else{
    mrow <- .cov2Dist(cov(mat))
    if(nrow(mrow) != nrow(mat))mrow <- .cov2Dist(cov(t(mat)))
  }
  list(cmat = mrow, DIST = DIST)
}

.clusterWithGrid <- function(mat1, mat2=NULL, opt, expand=1){
  
  #   layout: mat1 on left, mat2 (if given) on right
  # clusters: left & top or right & top
  #   expand: width of mat1 relative to mat2
  # if mat1/2 is symmetric can order only rows--stay symmetric
  # if DIST use distance, otherwise correlation
  
  leftClus <- rightClus <- 
    topClus1 <- topClus2 <- leftLab <- 
    rightLab <- topLab1 <- topLab2 <- lower1 <- diag1 <- lower2 <- 
    diag2 <- SYM1 <- SYM2 <- sameOrder <- FALSE
  colOrder1 <- colOrder2 <- rowOrder <- colCode1 <- colCode2 <- rowCode <- 
    slim1 <- slim2 <- horiz1 <- horiz2 <- vert1 <- vert2 <- NULL
  mainLeft <- main1 <- main2 <- ' '
  DIST1 <- DIST2 <- T
  ncluster <- 4
  
  for(k in 1:length(opt))assign( names(opt)[k], opt[[k]] )
  
  if(isSymmetric(mat1))SYM1 <- T
  
  doneLeft <- done1 <- done2 <- F
  
  nr  <- nrow(mat1)
  nc1 <- ncol(mat1)
  nc2 <- 0
  
  twoMat <- F
  if(!is.null(mat2)){
    if( min(dim(mat2)) < 2 )return()
    if(isSymmetric(mat2))SYM2 <- T
    twoMat <- T
    nc2 <- ncol(mat2)
    if(nrow(mat2) != nr)stop('matrices must have same no. rows')
  }
  cwide <- .15
  mg    <- .08
  lg    <- rg <- tg <- mg
  gg    <- .24
  
  if(leftLab) lg <- gg
  if(topLab1 | topLab2)  tg <- gg
  if(rightLab)rg <- gg
  
  xwide <- mg
  if(leftLab) xwide <- c(xwide,lg)
  if(leftClus)xwide <- c(xwide,cwide)
  
  xg <- .8
  if(twoMat){
    xg <- expand*xg*nc1/(nc1+nc2)
    xg <- c(xg,1 - xg)
  }
  xwide <- c(xwide,xg)
  
  if(rightClus)xwide <- c(xwide,cwide)
  if(rightLab) xwide <- c(xwide,rg)
  xwide <- c(xwide,mg)
  xloc <- cumsum(xwide)/sum(xwide)
  
  ywide <- c(mg,.8)
  if(topClus1 | topClus2)ywide <- c(ywide,cwide)
  if(topLab1 | topLab2) ywide <- c(ywide,tg)
  ywide <- c(ywide,mg)
  yloc  <- cumsum(ywide)/sum(ywide)
    
  if(is.null(rowCode)) rowCode  <- rep('black',nr)
  if(is.null(colCode1))colCode1 <- rep('black',nc1)
  if(is.null(colCode2))colCode2 <- rep('black',nc2)
  
  tmp   <- .clustMat(mat1, SYM1)
  m1Row <- tmp$cmat
  DIST1 <- tmp$DIST
  tmp <- .clustMat(t(mat1), SYM1)
  m1Col <- tmp$cmat
  

  if(is.null(rowOrder)){
    if(nrow(m1Row) != nrow(mat1))m1Row <- cor(t(mat1))
    if(ncluster > nrow(m1Row)/2)ncluster <- 2
    copt <- list( PLOT=F, DIST = DIST1, ncluster=ncluster )
    tmp  <- .clusterPlot( m1Row, copt)
    clus <- tmp$clusterIndex
    cord <- tmp$corder
    rowClust <- clus[cord]
    rowOrder <- cord
  }
  
  if(is.null(colOrder1)){
    if(SYM1){
      colOrder1 <- rowOrder
      colClust1 <- rowClust
    }else{
      copt      <- list( PLOT=F, DIST = DIST1, ncluster=ncluster )
      tmp  <- .clusterPlot( m1Col, copt)
      clus <- tmp$clusterIndex
      cord <- tmp$corder
      colClust1 <- clus[cord]
      colOrder1 <- cord
    }
  }
  
  if(twoMat){
    tmp   <- .clustMat(t(mat2), SYM2)
    m2Col <- tmp$cmat
    DIST2 <- tmp$DIST
    
    if(is.null(colOrder2)){
      if(sameOrder){
        colOrder2 <- rowOrder
        m2Col <- t(mat2)
      }else{
        copt <- list( PLOT=F, DIST = DIST2 )
        tmp  <- .clusterPlot( m2Col, copt)
        if(is.null(tmp)){
          colOrder2 <- 1:nrow(m2Col)
        }else{
        clus <- tmp$clusterIndex
        cord <- tmp$corder
        colClust2 <- clus[cord]
        colOrder2 <- cord
        }
      }
    }
  }
        
  rowLabs <- rownames(mat1)[rowOrder]
  
  #######################
  NEW <- add <- F
  xi <- 0:1
  yi <- 1:2
  
  ##### lab panel -- bottom to top
  if(leftLab){  
    xi <- xi + 1
    par(plt=c(xloc[xi],yloc[yi]),bty='n', new=NEW)
    
    plot(NULL,col='white',xlim=c(0,1),ylim=c(0,nr),
         xaxt='n',yaxt='n',xlab='',ylab='')
    xl  <- rep(1,nr)
    yl  <- c(1:nr)*nr/diff(par('usr')[3:4])
    cex <- .fitText2Fig(rowLabs,fraction=.96)
    text( xl,yl, rowLabs ,pos=2,cex=cex, 
          col = rowCode[rowOrder])
    NEW <- add <- T
    mtext(mainLeft,2)
    doneLeft <- T
  }
  
  #### cluster panel
  if(leftClus){
    xi <- xi + 1
    par(plt=c(xloc[xi],yloc[yi]),bty='n',  new=NEW)
    copt <- list( main=' ',cex=.2, colCode=rowCode, ncluster=ncluster,
                 LABELS = F, horiz=T, noaxis=T, DIST=DIST1 )
    tmp <- .clusterPlot( m1Row, copt)
    clus <- tmp$clusterIndex
    cord <- tmp$corder
    
    rowClust <- clus[cord]
    
    NEW <- add <- T
    if(!doneLeft)mtext(mainLeft,2)
    doneLeft <- T
  }
  
  ######## first grid plot
  
  xi <- xi + 1
  yz <- yi
  
  if(topClus1){
    yz <- yz + 1
    par(plt=c(xloc[xi],yloc[yz]),bty='n',new=NEW)
    
    copt <- list( main=' ', colCode=colCode1, DIST = DIST1,     
                 LABELS = F, horiz=F, noaxis=T, add=T )
    tmp <- .clusterPlot( m1Col ,copt)
    NEW <- add <- T
    if(!topLab1){
      mtext(main1,3)
      done1 <- T
    }
  }
  
  par(plt=c(xloc[xi],yloc[yi]), bty='n', new=NEW)
  mai <- mat1
  diag(mai) <- NA
  if(is.null(slim1))slim1 = quantile(mai,c(.01,.99), na.rm=T) ######
  slim1  <- signif(slim1,2)
  
  tmp    <- .colorSequence(slim1)
  scale  <- tmp$scale
  colseq <- tmp$colseq
  
  ww <- as.matrix(expand.grid(c(1:nr),c(1:nc1)))  # reverse order
  mt <- mat1[rev(rowOrder),colOrder1]
  
  win <- which(ww[,1] >= ww[,2])
  
  mask <- lower.tri(mt,diag=!diag1)
  mask <- apply(mask,2,rev)
  if(lower1){
    if(min(scale) > 0 | max(scale) < 0){mt[mask] <- mean(scale)
    }else{ mt[mask] <- 0 }
  }
  
  icol <- findInterval(mt[ww],scale,all.inside=T)
  coli <- colseq[icol]
  
  xlim=c(range(ww[,2])); xlim[2] <- xlim[2] + 1
  ylim=c(range(ww[,1])); ylim[2] <- ylim[2] + 1
  
  sides <- cbind( rep(1,nrow(ww)), rep(1,nrow(ww)) )
  plot(NULL,cex=.1,xlab=' ',ylab=' ', col='white',
       xaxt='n',yaxt='n', xlim=xlim, ylim=ylim)
  
  symbols(ww[,2] + .5,nr - ww[,1] + 1 + .5,rectangles=sides,
          fg=coli,bg=coli,inches=F, xlab=' ',ylab=' ',
          xaxt='n',yaxt='n', add=T)
  
  if(!is.null(horiz1)){
  #  cut <- which(diff(horiz1[rowOrder]) != 0) + 1
    
    cut <- which(diff(rowClust) != 0) + 1
      
    ncc <- length(cut)
    for(i in 1:ncc){
      lines(c(0,cut[i]-2),cut[c(i,i)],lty=2)
    }
    text(rep(1,ncc),cut,2:(ncc+1),pos=3)
  }
  
  
  
  if(!is.null(vert1)){
    
    cut <- which(diff(colClust1) != 0) + .5
    ncc <- length(cut)
    for(i in 1:ncc){
      lines(cut[c(i,i)],c(cut[i]+2,nc1),lty=2)
    }
    text(cut,rep(nc1,ncc),2:(ncc+1),pos=4)
  }
  
  NEW <- add <- T
  if(!doneLeft)mtext(mainLeft,2)
  doneLeft <- T
  
  if(topLab1){
    yz <- yz + 1
    par(plt=c(xloc[xi], yloc[yz]),bty='n', new=NEW)
    plot(c(0,0),c(0,0),col='white',xlim=c(1,nc1) ,ylim=c(0,1),
         xaxt='n',yaxt='n',xlab='',ylab='')
    yl <- rep(0,nc1)
    xl <- .99*c(1:nc1)*(nc1-1)/diff(par('usr')[1:2])
 #   xl <- .95*c(1:nc1)*nc1/diff(par('usr')[1:2])
    cex <- .fitText2Fig(colnames(m1Col), 
                        width=F, fraction=.95)
    text( xl - .1,yl,colnames(m1Col)[colOrder1],pos=4,cex=cex,srt=90,
          col=colCode1[colOrder1])
  }
  if(!done1)mtext(main1,3)
  
  #color scale
  par(plt=c(xloc[xi],c(.3*yloc[yi[1]],yloc[yi[1]])), bty='n', new=NEW)
  lx1 <- .3
  lx2 <- .7
  
  lx <- seq(lx1,lx2,length=length(scale))
  wx <- diff(lx)[1]
  ly <- lx*0 + .3*yloc[yi[1]]
  rx <- cbind(lx*0 + wx, ly*0 + .7*diff(yloc[yi]))
  symbols(lx,ly,rectangles=rx,fg=colseq,bg=colseq,xaxt='n',yaxt='n',
          xlab='',ylab='',xlim=c(0,1),ylim=c(0,yloc[yi[1]]))
  text(lx[1],ly[1],slim1[1],pos=2, cex=.9)    
  text(lx[length(lx)],ly[1],slim1[2],pos=4, cex=.9)  
  
  ######## 2nd grid plot
  
  if(twoMat){
    
    xi <- xi + 1
    yz <- yi
 
    if( topClus2 ){
      yz <- yz + 1
      par(plt=c(xloc[xi],yloc[yz]),bty='n',new=NEW)
      
      copt <- list( main=' ', LABELS = F,
                   colCode=colCode2, horiz=F, 
                   noaxis=T, add=T, DIST=DIST2 )
      ttt <- .clusterPlot( m2Col, copt)
      
      if(!topLab2){
        mtext(main2,3)
        done2 <- T
      }
    }
    
    par(plt=c(xloc[xi],yloc[yi]), bty='n', new=T)
    if(is.null(slim2))slim2 = quantile(mat2,c(.01,.99))
    slim2  <- signif(slim2,1)
    
    tmp <- .colorSequence(slim2)
    scale  <- tmp$scale
    colseq <- tmp$colseq
    
    ww    <- as.matrix(expand.grid(c(1:nr),c(1:nc2)))  # note reverse order
    mt    <- mat2[rev(rowOrder),colOrder2]
    
    if(lower2){
      mask <- lower.tri(mt,diag=!diag1)
      mask <- apply(mask,2,rev)
      mt[mask] <- 0
      if(min(scale) > 0 | max(scale) < 0){
        mt[mask] <- mean(scale)
      }else{ mt[mask] <- 0 }
    }
    
    icol <- findInterval(mt[ww],scale,all.inside=T)
    coli <- colseq[icol]
    
    xlim=c(range(ww[,2])); xlim[2] <- xlim[2] + 1
    ylim=c(range(ww[,1])); ylim[2] <- ylim[2] + 1
    
    sides <- cbind( rep(1,nrow(ww)), rep(1,nrow(ww)) )
    plot(0,0,cex=.1,xlab=' ',ylab=' ',
         col='white',xaxt='n',yaxt='n', xlim=xlim, ylim=ylim)
    
    symbols(ww[,2] + .5,nr - ww[,1] + 1 + .5, rectangles=sides,
            fg=coli, bg=coli, inches=F, xlab=' ',ylab=' ',
            xaxt='n', yaxt='n', add=T)
    
    if(!is.null(horiz2)){
      
      cut <- which(diff(rowClust) != 0) + 1
      ncc <- length(cut)
      for(i in 1:ncc){
        xmm <- c(0,cut[i]-2)
        if(!lower2)xmm[2] <- nc2 + 1
        lines(xmm,cut[c(i,i)],lty=2)
      }
      if(lower2) text(rep(1,ncc),cut,2:(ncc+1),pos=3)
      if(!lower2)text(rep(nc2+1,ncc),cut,2:(ncc+1),pos=3)
    }
    if(!is.null(vert2)){
      cut <- which(diff(vert2[colOrder2]) != 0) + .5
      ncc <- length(cut)
      for(i in 1:ncc){
        lines(cut[c(i,i)],c(cut[i]+2,nc1),lty=2)
      }
      text(cut,rep(nc1,ncc),2:(ncc+1),pos=4)
    }
    
    if(topLab2){
      yz <- yz + 1
      par(plt=c(xloc[xi],yloc[yz]),bty='n', new=NEW)
      plot(c(0,0),c(0,0),col='white',xlim=c(1,nc2),ylim=c(0,1),
           xaxt='n',yaxt='n',xlab='',ylab='')
      yl  <- rep(0,nc2)
      xl  <- c(1:nc2)*(nc2-1)/diff(par('usr')[1:2])
      if(xl[1] < 1)xl[1] <- 1.2
      cex <- .fitText2Fig(colnames(m2Col),width=F, fraction=.95)
      text( xl - .05,yl,colnames(m2Col)[colOrder2],pos=4,cex=cex,srt=90, 
            col=colCode2[colOrder2])
    }
    if(!done2)mtext(main2,3)
  }
  
  par(plt=c(xloc[xi],c(.3*yloc[yi[1]],yloc[yi[1]])), bty='n', new=NEW)
  
  lx1 <- .3
  lx2 <- .7
  
  lx <- seq(lx1,lx2,length=length(scale))
  wx <- diff(lx)[1]
  ly <- lx*0 + .3*yloc[yi[1]]
  rx <- cbind(lx*0 + wx, ly*0 + .7*diff(yloc[yi]))
  symbols(lx,ly,rectangles=rx,fg=colseq,bg=colseq,xaxt='n',yaxt='n',
          xlab='',ylab='',xlim=c(0,1),ylim=c(0,yloc[yi[1]]))
  text(lx[1],ly[1],slim2[1],pos=2, cex=.9)    
  text(lx[length(lx)],ly[1],slim2[2],pos=4, cex=.9)  
  
  if(rightClus){
    xi <- xi + 1
    par(plt=c(xloc[xi], yloc[yi]), bty='n', mgp=c(3,1,0), new=NEW)
    mmm <- .distanceMatrix(t(mat2), DIST1)
    copt <- list( main=' ',cex=.2, REV=T,
                 LABELS = F,horiz=T, noaxis=T )
    tmp <- .clusterPlot( mmm , copt)
  }
  
  if(rightLab){
    xi <- xi + 1
    par(plt=c(xloc[xi],yloc[yi]),bty='n', new=NEW)
    plot(c(0,0),c(0,0),col='white',xlim=range(c(0,1)),ylim=c(0,nr),
         xaxt='n',yaxt='n',xlab='',ylab='')
    xl <- rep(0,nr)
    yl <- c(1:nr)*nr/diff(par('usr')[3:4])
    cex <- .fitText2Fig(rownames(m1Row),fraction=.8)
    text( xl,yl,rev( rownames(m1Row) ),pos=4,cex=cex,
          col=rev(rowCode[rowOrder]))
  }
}

.clusterPlot <- function(dmat, opt = NULL){
  
  main <- xlab <- ' '
  method <- 'complete' 
  cex <- 1; ncluster <- 2; textSize <- 1
  add <- REV <- reverse <- noaxis <- DIST <- F
  xlim <- colCode <- NULL 
  horiz <- LABELS <- PLOT <- T

  for(k in 1:length(opt))assign( names(opt)[k], opt[[k]] )
  
  #dmat is a correlation matrix or distance matrix
  
  getTreeLabs <- function ( tree ){ #left to right or bottom to top
    
    getL <- function(tree_node) {
      if(is.leaf(tree_node)) 
        attr(tree_node, 'label')
    }
    unlist( dendrapply(tree, getL) )
  }
  nr   <- nrow(dmat)
  nn   <- nrow(dmat)
  
  if( min(c(nr,nn) ) < 3)return()
  
  if(DIST){
    if(!isSymmetric(dmat))dmat <- dist(dmat)
    diss <- as.dist( dmat )
  }else{
    diss <- as.dist(.cov2Dist(dmat))
  }
  
  htree  <- hclust(diss,method)
  ctmp   <- cutree(htree,k=1:ncluster)
  
  wclus <- ctmp[,ncluster]
  clusterCol <- NULL
  
  clusterIndex <- ctmp[, ncluster, drop=F]
  clusterList <- character(0)
  
  notLab <- F
  if(is.null(colCode)){
    colF   <- colorRampPalette(c('black','blue','orange','brown','red'))
    mycols <- colF(ncluster)
    notLab <- T
    colCode <- mycols[ctmp[,ncluster]]
    names(colCode) <- rownames(ctmp)
  }
  col.lab <- colCode
  if(!LABELS)col.lab <- rep('white',length(colCode))
  
  colLab <- function(n) {
 
    if(is.leaf(n)) {
      a <- attributes(n)
      attr(n, "nodePar") <- c(a$nodePar, 
                              list(col = col.lab[n[1]],
                                   lab.col = col.lab[n[1]]))
    }
    n
  }
  tdendro <- as.dendrogram(htree)
  if(reverse)tdendro <- rev(tdendro)
  dL      <- dendrapply(tdendro,colLab)
  
  tlab <- getTreeLabs(tdendro)
  corder <- match(tlab,colnames(dmat))
  names(corder) <- colnames(dmat)[corder]
  
  nodePar <- list(cex = .1, lab.cex=textSize)
    leafLab         <- "textlike"
    nodePar$leaflab <-  leafLab
    
  if(!PLOT){
    return(  invisible(list( clusterList = clusterList, colCode = colCode, 
                    clusterIndex = clusterIndex,
                    corder = corder) ) )
  }
    
    if(horiz){
      if(is.null(xlim))xlim <- c(attr(dL,'height'),0)
      if(REV)xlim <- rev(xlim)
    }
    
  axes <- T
  if(noaxis)axes <- F
  new <- F
  if(add)new <- T
 
  tmp <- plot( dL,nodePar=nodePar, horiz=horiz, xlim=xlim, 
               axes = axes)
  if(!LABELS & !notLab){
    
    col <- colCode[corder]
    pvar <- par('usr')
    
    wi <- abs(diff(pvar[1:2])/10)
    hi <- abs(diff(pvar[3:4])/10)
    
    if(horiz){
      xx <- rep(pvar[2],nn)
      yy <- 1:nn
      rec <- cbind( rep(wi,nn), rep(1,nn) )
      symbols(xx,yy,rectangles=rec,fg=col, bg=col, inches=F, add=T)
    } else {
      xx <- 1:nn
      yy <- rep(pvar[3],nn)
      rec <- cbind( rep(1,nn), rep(hi,nn) )
      symbols(xx,yy,rectangles=rec,fg=col, bg=col, inches=F, add=T)
    }
  }
  
  title(main)
  
  invisible(list( clusterList = clusterList, colCode = colCode, 
                  clusterIndex = clusterIndex,
                  corder = corder) )

}

.colorLegend <- function(xx,yy,ytick=NULL,
                         scale=seq(yy[1],yy[2],length=length(cols)),
                        cols,labside='right', text.col=NULL,
                        bg=NULL,endLabels=NULL){  
  # xx = (x1,x2), y = (y1,y2)
  # bg is color of border

  nn <- length(scale)
  ys <- seq(yy[1],yy[2],length=nn)

  for(j in 1:(length(scale)-1)){
    rect(xx[1],ys[j],xx[2],ys[j+1],col=cols[j],border=NA)
  }
  if(!is.null(bg))rect(xx[1],yy[1],xx[2],yy[2],border=bg,lwd=3)
  if(!is.null(ytick)){
    
    ys <- diff(yy)/diff(range(ytick))*ytick
    yt <- ys - min(ys) + yy[1]
    
    for(j in 1:length(yt)){
      lines(xx,yt[c(j,j)])
    }
  }
  if(!is.null(endLabels)){ 
    cx <- cols[c(1,nn)]
    if(!is.null(text.col))cx <- text.col
    if(!is.null(text.col))cx <- text.col
    if(labside == 'right')text(diff(xx)+c(xx[2],xx[2]),yy,endLabels,col=cx)
    if(labside == 'left')text(c(xx[1],xx[1]),yy,endLabels,pos=2,col=cx)
  }
}

.capFirstLetter <- function(xx) {     
  
  #capiltalize first letter of every word
  
  s <- unlist(strsplit(xx, " "))
  s <- paste(toupper(substring(s, 1, 1)), substring(s, 2),
             sep = "", collapse = " ")
  unlist(strsplit(s, " "))
}

.lowerFirstLetter <- function(xx){
  s <- unlist(strsplit(xx, " "))
  s <- paste(tolower(substring(s, 1, 1)), substring(s, 2),
             sep = "", collapse = " ")
  unlist(strsplit(s, " "))
}

.colorSequence <- function(slim, colorGrad=NULL, ncol=200){  
  
  # generate color sequence with white for zero
  # slim is scale from min to max
  # used in .corPlot
  
  if(is.null(colorGrad)){
    colorSeq <- c('darkblue','darkblue','blue',
                  'green','white',
                  'yellow','red','brown','brown')
    colorSeq <- rev( c('#a50026','#d73027','#f46d43',
                       '#fdae61','#fee090','#ffffbf',
                       '#e0f3f8','#abd9e9','#74add1',
                       '#4575b4','#313695') )
    colorGrad   <- colorRampPalette(colorSeq)
  }
  
  colseq <- colorGrad(ncol)
  
  if(slim[1] < 0 & slim[2] > 0){  #put white at zero
    dp <- slim[2] - 0
    dm <- 0 - slim[1]
    ncol <- 200
    
    colseq <- colorGrad(ncol)
    if(dp < dm)colseq <- colseq[101 + c(-100:round(dp/dm*100))]
    if(dp > dm)colseq <- colseq[ round((1 - dm/dp)*100):200 ]
    ncol  <- length(colseq)
  }
  scale <- seq(slim[1],slim[2],length.out=ncol)
  list(colseq = colseq, scale = scale )
}

.corPlot <- function(cmat, slim=NULL,PDIAG=F,plotScale=1,
                    makeColor=NULL,textSize=NULL,
                    textCol = rep('black',nrow(cmat)), 
                    CORLINES=T,tri='lower',colorGrad = NULL,
                    cex=1, SPECLABS = T, squarePlot = T,LEGEND = T,
                    widex=5.5,widey=6.5,add=F,new=T){  
  # correlation or covariance matrix
  # makeColor - list of matrices of indices for boxes
  #   names of matrices are colors
  # if(PDIAG)diag(cmat) <- 0
  # tri - 'lower','upper', or 'both'
  # colorGrad - constructed with colorRampPalette()
  # squarePlot makes symbols square
  # new means NOT NEW 

  if(is.null(slim))slim = quantile(cmat,c(.01,.99))
  slim  <- signif(slim,1)
  
  if(tri == 'upper')cmat[lower.tri(cmat)] <- 0
  if(tri == 'lower')cmat[upper.tri(cmat)] <- 0

  dy  <- nrow(cmat)
  dx  <- ncol(cmat)
  d <- dx
  xtext <- rep(c(1,100),dx/2)
  if(length(xtext) < d)xtext <- c(xtext,1)

  if(d < 20)xtext <- xtext*0 + 1

  xtext <- xtext*0 + 1
  
  if(!is.null(colorGrad)){
    ncol  <- 200
    colseq <- colorGrad(ncol)
    scale  <- seq(slim[1],slim[2],length.out=ncol)
  } else {
    tmp <- .colorSequence(slim, colorGrad)
    scale  <- tmp$scale
    colseq <- tmp$colseq
  }
  
  ww   <- as.matrix(expand.grid(c(1:dy),c(1:dx)))  # note reverse order

  if(tri == 'upper'){
    ww  <- ww[ww[,1] <= ww[,2],]
    ww  <- ww[order(ww[,1]),]
  }
  if(tri == 'lower'){
    ww  <- ww[ww[,1] >= ww[,2],]
    ww  <- ww[order(ww[,1]),]
  }

  icol <- findInterval(cmat[ww],scale,all.inside=T)
  coli <- colseq[icol]

  if(PDIAG)coli[ww[,1] == ww[,2]] <- 'white'
  
  ss <- max(c(dx,dy))/5/plotScale
  
  if(squarePlot).mapSetup(c(0,dx),c(0,dy),scale=ss,
                          widex=widex,widey=widey)
  
  if(squarePlot){
    symbols(ww[,2],dy - ww[,1] + 1,squares=rep(1,nrow(ww)),
            xlim=c(0,dx+4),ylim=c(0,dy+4),
            fg=coli,bg=coli,inches=F,xlab=' ',ylab=' ',xaxt='n',yaxt='n',
            add=add)
  } else {
    sides <- cbind( rep(1,nrow(ww)), rep(1,nrow(ww)) )
    symbols(ww[,2],dy - ww[,1] + 1,rectangles=sides,
            xlim=c(0,dx+4),ylim=c(0,dy+4),
            fg=coli,bg=coli,inches=F,xlab=' ',ylab=' ',xaxt='n',yaxt='n',
            add=add)
  }
  
  if(!is.null(makeColor)){
    
    for(k in 1:length(makeColor)){
      mm <- makeColor[[k]]
      if(length(mm) == 0)next
      if(tri == 'upper')mm <- mm[mm[,1] <= mm[,2],]
      if(tri == 'lower')mm <- mm[mm[,1] >= mm[,2],]
      ss <- matrix(0,dy,dx)
      ss[mm] <- 1
      wk <- which(ss[ww] == 1)
      ccc <- names(makeColor)[[k]]
      symbols(ww[wk,2],dy - ww[wk,1]+1,squares=rep(1,length(wk)),
              fg=ccc,bg=ccc,inches=F,xaxt='n',yaxt='n',add=T)
    }
  }
  
  ncolor <- length(unique(textCol))
  
  ll <- 1/d + 1
  
  if(tri == 'lower'){
    for(kk in 1:d){
      kb <- kk - .5
      ke <- d - kk + .5
      
      if(CORLINES){
        if(kk <= d)lines(c(kb,kb),c(0,ke),col='grey',lwd=1.5) #vert
        if(kk > 1){
          lines( c(.5,kb),c(ke,ke),col='grey',lwd=1.5)        #horizontal
          lines(c(kb,kb+.5),c(ke,ke+.5),col='grey',lwd=1.5)   #diagonal
        }
      }
      if(!SPECLABS & ncolor > 1){
        xp <- c(kb, kb, kb + ll + .5, kb + ll + 1.5, kb + 1)
        yp <- c(ke, ke + 1, ke + ll + 1.5, ke + ll + .5, ke)
        polygon(xp, yp, border = textCol[kk], col = textCol[kk])
      }
    }
  }
  rect(0,-1,d+1,.5,col='white',border=NA)
  
  if(is.null(textSize))textSize <- exp(-.02*ncol(cmat))
  labels   <- rev(rownames(cmat))
  if(!SPECLABS)labels <- F
  
  if(tri == 'lower' & SPECLABS)text( c(d:1)+.1*xtext, c(1:d)+.5, 
                                     rev(colnames(cmat)),pos=4,srt=45,
                                     col = rev(textCol), cex=textSize)
  
  if(tri == 'both'){
    labels   <- rev(rownames(cmat))
    par(las = 1)
    
    .yaxisHorizLabs( labels, at=c(1:length(labels)), xshift=.05,
                                 col = textCol, pos=2)
    
    par(las = 0)
    
    if(SPECLABS){
      text( c(dx:1)-.1*xtext, xtext*0+dy+.8, rev(colnames(cmat)),
                      pos=4, srt=55, col = rev(textCol), cex=textSize)
    } else {
      sides <- cbind( rep(1,dx),rep(1/dy,dx) )
      symbols(1:dx,rep(1+dy,dx),rectangles=sides,
              fg=textCol,bg=textCol,
              add=T)
    } 
      
  }
  
  labside <- 'left'
  
  wk <- which(scale >= slim[1] & scale <= slim[2]) 
  
  px <- par('usr')
  xs <- .01*diff(px[1:2])
  midx <- .95*mean( c(dx,px[2]) )
  
  yx <- c(1*dy - .25*dy, 1*dy )
  
  if(LEGEND).colorLegend(c(midx-xs,midx+xs),yx,ytick=c(slim[1],0,slim[2]),
                        scale[wk],cols=colseq[wk],labside=labside,
                        endLabels=range(slim),text.col='black')
}

.cor2Cov <- function(sigvec,cormat){ 
  
  #correlation matrix and variance vector to covariance
  
  n <- nrow(cormat)
  d <- length(sigvec)
  if(d == 1)sigvec <- rep( sigvec, n )
  
  s <- matrix(sigvec,n,n)
  cormat*sqrt(s*t(s))
}

.cov2Cor <- function(covmat, covInv = NULL){  
  
  # covariance matrix to correlation matrix
  # if covInv provided, return inverse correlation matrix

  d    <- nrow(covmat)
  di   <- diag(covmat)
  s    <- matrix(di,d,d)
  cc   <- covmat/sqrt(s*t(s))
  
  if(!is.null(covInv)){
    dc <- diag(sqrt(di))
    ci <- dc%*%covInv%*%dc
    return(ci)
  }
  cc
}

.cov2Dist <- function(sigma){ 
  
  #distance induced by covariance
	
	n <- nrow(sigma)
	matrix(diag(sigma),n,n) + matrix(diag(sigma),n,n,byrow=T) - 2*sigma
}

.dMVN <- function(xx,mu,smat=NULL,sinv=NULL,log=F){ 
  
  #MVN density for mean 0
  
  if( !is.matrix(xx) )xx <- matrix(xx,1)
  if( !is.matrix(mu) )mu <- matrix(mu,1)
  
  if(length(smat) > 0){
    tmp <- try( dmvnormRcpp(xx, mu, smat, logd=log),silent=T  )     
    if( !inherits(tmp,'try-error') )return(tmp)
  }
  
  ss <- xx - mu
  k  <- ncol(xx)
  
  if( !is.null(sinv) ){
    
    logdet <- log( det(sinv) )
    z <- rowSums( ss %*% sinv * ss)
    
    dens <- as.vector((-k/2) * log(2 * pi) + 0.5 * logdet - 
                        0.5 * z)
    if (log == FALSE) 
      dens <- exp(dens)
    return(dens)  
  }
}

.directIndirectCoeffs <- function( snames, xvector, chains, MEAN = T,
                                   factorList = NULL, keepNames, omitY,
                                   sdScaleY = F, sdScaleX, standX, 
                                   otherpar = NULL, REDUCT = F, ng, burnin,
                                   nsim = 50){
  
  # if MEAN, then use means, otherwise median
  # indirect do not change with x, can choose not to calculate
  #          - a list of vectors, one for each multilevel factor, 
  #            where hostNames appear in colnames of bchain
  #indirFrom - effect from all others
  #indirTo   - effect on all others
  
  if(is.matrix(xvector))
    stop('xvector must be a row vector with variable names')
  
  xnames <- names(xvector)
  
  N      <- otherpar$N
  r      <- otherpar$r
  bchain <- chains$bgibbs
  schain <- chains$sgibbs
  sigErrGibbs <- kchain <- NULL
  if(REDUCT){
    kchain      <- chains$kgibbs
    sigErrGibbs <- chains$sigErrGibbs
  }
  
  ns <- nsim
  simIndex <- sample(burnin:ng,ns,replace=T)
  
  if(sdScaleY){
    tmp <- .expandSigmaChains(snames, sgibbs = schain, otherpar = otherpar, 
                              simIndex = simIndex, sigErrGibbs, kchain, 
                              REDUCT, CHAINSONLY=F, verbose = FALSE)

    if(REDUCT)kchain <- kchain[simIndex,]
    schain <- schain[simIndex,]          # not standardized
    sigErrGibbs <- sigErrGibbs[simIndex]
  } else {
    bchain <- bchain[simIndex,]
    schain <- schain[simIndex,]
  }
  
  if(length(factorList) > 0){
    factorNames <- factorList
    for(j in 1:length(factorList)){
      tmp <- matrix( unlist(strsplit(factorList[[j]],names(factorList)[j])),
                     ncol=2,byrow=T)[,2]
      tmp[nchar(tmp) == 0] <- paste(names(factorList)[j],c(1:length(tmp)),
                                    sep='')
      factorNames[[j]] <- tmp
    }
  }
  
  S <- S1 <- length(snames)
  sindex <- c(1:S)
  knames <- snames
  
  nc <- nrow(bchain)
  gs <- 1:nrow(bchain)
  
  if(length(omitY) > 0){
    wob <- grep(paste(omitY,collapse="|"),colnames(bchain))
    bchain[,wob] <- 0
    sindex <- sindex[!snames %in% omitY]
    knames <- snames[sindex]
    S1     <- length(knames)
  }
  
  nspec <- length(snames)
 
  ww   <- grep(':',xnames)
  main <- xnames
  if(length(ww) > 0)main <- xnames[-ww]
  main <- main[main != 'intercept']
  int  <- unique( unlist( strsplit(xnames[ww],':') ) ) 
  
  mainEffect <- matrix(NA,nspec,length(main))
  colnames(mainEffect) <- main
  rownames(mainEffect) <- snames
  intEffect  <- dirEffect <- indEffectTo <- mainEffect
  mainSd <- dirSd <- intSd <- indSdTo <- mainEffect 
  
  maxg <- length(main)*length(sindex)*length(gs)
  pbar <- txtProgressBar(min=1,max=maxg,style=1)
  ig   <- 0
  
  for(j in 1:length(main)){
    
    ttt <- .interactionsFromGibbs(mainx=main[j], bchain=bchain,
                                  specs=snames, xmnames=names(xvector), 
                                  xx=xvector, omitY = omitY, sdScaleX=F, 
                                  standX)
    maine   <- ttt$main
    inter   <- ttt$inter  #
    indirTo <- maine*0
    direct  <- maine + inter  # already standardized for X
    
    if(MEAN){
      dmain  <- colMeans(maine)
      inte   <- colMeans(inter)
      dir    <- colMeans(direct)
    } else {
      dmain  <- apply(maine,2,median)
      inte   <- apply(inter,2,median)
      dir    <- apply(direct,2,median)
    }
    
    mainEffect[sindex,j] <- dmain
    intEffect[sindex,j]  <- inte
    dirEffect[sindex,j]  <- dir
    
    mainSd[sindex,j] <- apply(maine,2,sd)
    intSd[sindex,j]  <- apply(inter,2,sd)
    dirSd[sindex,j]  <- apply(direct,2,sd)
    
    for(g in gs){
      
      if(REDUCT){
        Z  <- matrix(schain[g,],N,r)
        ss <- .expandSigma(sigErrGibbs[g], S, Z = Z, kchain[g,], 
                           REDUCT = T)[sindex,sindex]
        if(sdScaleY)cc <- .cov2Cor(ss)
      } else {
        ss <- .expandSigma(schain[g,], S = S, REDUCT = F)[sindex,sindex]
        if(sdScaleY)cc <- .cov2Cor(ss)
      }
      
      for(s in 1:length(sindex)){
        
        if(REDUCT){
          si <- invWbyRcpp(sigErrGibbs[g], Z[kchain[g,sindex[-s]],])
          if(sdScaleY){
            dc <- diag(sqrt(diag(ss)))[-s,-s]
            ci <- dc%*%si%*%dc
          }
        } else {
          si <- solveRcpp(ss[-s,-s])
          if(sdScaleY)ci <- solveRcpp(cc[-s,-s])
        }
        
        if(!sdScaleY){
          sonk <- ss[drop=F,s,-s]
          e2   <- sonk%*%si%*%direct[g,-s]
        } else {
          sonk <- cc[drop=F,s,-s]
          e2   <- sonk%*%ci%*%direct[g,-s]      # correlation scale
        }
        indirTo[g,s] <- e2
        
        ig <- ig + 1
        setTxtProgressBar(pbar,ig)
        
      } ##############
    }
    
    if(MEAN){
      indirectTo   <- colMeans(indirTo[gs,])
    } else {
      indirectTo   <- apply(indirTo[gs,],2,median)
    }
    indEffectTo[sindex,j]   <- indirectTo
    indSdTo[sindex,j]       <- apply(indirTo[gs,],2,sd)
  } ######################################
  
  if(!is.null(keepNames)){
    wk <- which(rownames(mainEffect) %in% keepNames)
    mainEffect <- mainEffect[wk,]
    intEffect <- intEffect[wk,]
    dirEffect <- dirEffect[wk,]
    indEffectTo   <- indEffectTo[wk,]
    mainSd    <- mainSd[wk,]
    dirSd     <- dirSd[wk,]
    indSdTo   <- indSdTo[wk,]
  }
  
  list(mainEffect = mainEffect, intEffect = intEffect, dirEffect = dirEffect,
       indEffectTo = indEffectTo, mainSd = mainSd, dirSd = dirSd,
       intSd = intSd, indSdTo = indSdTo)
}

.interactionsFromGibbs <- function(mainx,bchain,specs,xmnames=names(xx),
                                   xx=colMeans(xx), omitY=NULL, sdScaleX, 
                                   standX){
  
  # returns main effects and interactions for variable named main
  # xx are values of covariates to condition on
  # mainx is the name of a main effect
  
  if(length(omitY) > 0){
    wob <- numeric(0)
    for(k in 1:length(omitY)){
      wob <- c(wob, grep(omitY[k],colnames(bchain)))
    }
    bchain[,wob] <- 0
    specs <- specs[!specs %in% omitY]
  }
  
  ww   <- grep(':',xmnames)
  int  <- unique( unlist( strsplit(xmnames[ww],':') ) ) 
  int  <- int[int != mainx]
  
  xj <- paste(mainx,specs,sep='_')
  wj <- which(colnames(bchain) %in%  xj)
  if(length(wj) == 0){
    xj <- paste(specs,mainx,sep='_')
    wj <- which(colnames(bchain) %in%  xj)
  }
  
  maine <- bchain[,xj]
  inter <- maine*0
  
  m1 <- paste(mainx,':',sep='')
  m2 <- paste(':',mainx,sep='')
  i1 <- grep( m1,xmnames )
  i2 <- grep( m2,xmnames )
  
  if(sdScaleX)maine <- maine*standX[mainx,'xsd']  #standardize main effect
  
  if( length(i1) > 0 ){
    
    ww <- match(unlist( strsplit(xmnames[i1],m1) ),xmnames)
    ox <- xmnames[ww[is.finite(ww)]]
    for(kk in 1:length(i1)){
      xi <- paste(xmnames[i1[kk]],specs,sep='_')
      wi <- which(colnames(bchain) %in%  xi)
      if(length(wi) == 0){
        xi <- paste(specs,xmnames[i1[kk]],sep='_')
        wi <- which(colnames(bchain) %in%  xi)
      }
      xik   <- xx[ox[kk]]
      bik   <- bchain[,xi]
      if(sdScaleX){
        xik <- (xik - standX[ox[kk],'xmean'])/standX[ox[kk],'xsd']
        bik <- bik*standX[mainx,'xsd']*standX[ox[kk],'xsd']
      }
      inter <- inter + bik*xik
    }
  }
  
  if( length(i2) > 0 ){
    
    ww <- match(unlist( strsplit(xmnames[i2],m2) ),xmnames)
    ox <- xmnames[ww[is.finite(ww)]]
    for(kk in 1:length(i2)){
      xi <- paste(xmnames[i2[kk]],specs,sep='_')
      wi <- which(colnames(bchain) %in%  xi)
      if(length(wi) == 0){
        xi    <- paste(specs,xmnames[i2[kk]],sep='_')
        wi <- which(colnames(bchain) %in%  xi)
      }
      xik   <- xx[ox[kk]]
      bik   <- bchain[,xi]
      if(sdScaleX){
        xik <- (xik - standX[ox[kk],'xmean'])/standX[ox[kk],'xsd']
        bik <- bik*standX[mainx,'xsd']*standX[ox[kk],'xsd']
      }
      inter <- inter + bik*xik
    }
  }
  list(main = maine, inter = inter)
}

.stackedBoxPlot <- function( stackList, stackSd=character(0),
                            ylim=NULL,sortBy = NULL, barnames=NULL,
                            col=rep(NULL,length(stackList)),
                            border=rep(NA,length(stackList)),
                            decreasing=T, nsd=1.96, cex=1,
                            legend=NULL, scaleLegend=.1){
  
  # sortBy - if length 1 indicates which variable in stackList to sort by
  #        - if a vector it is the order to plot
  # nds    - no. standard deviations for whiskers
  
  nn  <- length(stackList)
  ord <- c(1:length(stackList[[1]]))
  nx  <- length(ord)
  
  xx <- 0:(nx-1)
  
  if(is.null(ylim)){
    
    ymax <- ymin <- 0
    
    for(j in 1:nn){
      ymax <- ymax + max( c(0,stackList[[j]]),na.rm=T )
      ymin <- ymin + min( c(0,stackList[[j]]),na.rm=T )
    }
    
    ylim <- c(ymin,ymax)
    
    yscale <- diff(ylim,na.rm=T)*.4
    ylim[1] <- ylim[1] - yscale
    ylim[2] <- ylim[2] + yscale
  }
  
  if(!is.null(sortBy)){
    
    if(length(sortBy) > 1){
      ord <- sortBy
    } else {
      ord <- order( stackList[[sortBy]], decreasing = decreasing)
    }
    if(!is.null(barnames))barnames <- barnames[ord]
  }
  
  dy   <- diff(ylim)
  xlim <- c(0,1.2*length(ord))

  add <- F
  
  offset <- offsetPos <- offsetNeg <- rep(0,length(stackList[[1]]))
  
  if(is.null(col))col <- c(1:nn)
  
  for(j in 1:nn){
    
    xj <- stackList[[j]][ord]
    names(xj) <- NULL
    
    wp <- which(xj > 0)     # increase
    wn <- which(xj < 0)     # decrease
    
    offset[wp] <- offsetPos[wp]
    offset[wn] <- offsetNeg[wn]
    
    hj <- xj 
    
    barplot(height= hj,offset=offset,xlim=xlim,ylim=ylim,
            col=col[j],border=border[j],add=add)
    
    ww <- grep(names(stackList)[j],names(stackSd))
    if(length(ww) > 0){
      xz <- xx + .5
      xz <- xz*1.2
      
      tall <-  nsd*stackSd[[ww]]
      y1   <-  hj + offset + tall
      y2   <-  hj + offset - tall
      
      for(i in 1:length(ord)){
        lines(xz[c(i,i)],c(y1[i],y2[i]),lwd=6,col='white')
        lines(c(xz[i]-.1,xz[i]+.1),y1[c(i,i)],lwd=6,col='white')
        lines(c(xz[i]-.1,xz[i]+.1),y2[c(i,i)],lwd=6,col='white')
        
        lines(xz[c(i,i)],c(y1[i],y2[i]),lwd=2,col=col[j])
        lines(c(xz[i]-.1,xz[i]+.1),y1[c(i,i)],lwd=2,col=col[j])
        lines(c(xz[i]-.1,xz[i]+.1),y2[c(i,i)],lwd=2,col=col[j])
      }
    }
    
    if(j == 1)add <- T
    
    offsetPos[wp] <- offsetPos[wp] + hj[wp]
    offsetNeg[wn] <- offsetNeg[wn] + hj[wn]
    
    if(j == nn & !is.null(barnames)){
      
      xall <- par('usr')[1:2]
      xtic <- c(1:nx)*(diff(xall) - 1)/nx - .8
      
      yy <- offsetPos + .2*dy
      pos <- yy*0 + 1
      wl <- which(abs(offsetNeg) < abs(offsetPos))
      yy[wl] <- offsetNeg[wl] - .2*dy
      pos[wl] <- 4
      text(xtic,yy,barnames,srt=90.,pos=pos,cex=cex)
    }
  } 
  
  if(!is.null(legend)){
    
    dy <- diff(ylim)*scaleLegend
    dx <- 1.2
    x1 <- length(ord)*.02 + 1
    y1 <- ylim[1]
    pos <- 4
    if(legend == 'topright'){
      x1  <- length(ord)
      y1  <- ylim[2]
      dy  <- -dy
      dx <- -dx
      pos <- 2
    }
    if(legend == 'topleft'){
      y1  <- ylim[2]
      dy  <- -dy
    }
    if(legend == 'bottomright'){
      x1  <- length(ord)
      dx <- -dx
      pos <- 2
    }
    for(j in 1:length(stackList)){
      y2 <- y1 + dy
      rect(x1,y1,x1 + 1,y2,col=col[j],border=border[j])
      y1 <- y2
      colj <- col[j]
      if(colj == 'white')colj <- border[j]
      text(x1 + dx,y1 - dy/2,names(stackList)[[j]],col=colj,pos=pos,cex=cex)
    }
  }
  
  invisible( ord )
}  

.getScoreNorm <- function(x,mu,xvar){  #Gneiting/ Raftery proper scoring rule

  #outcome x, prediction mean variance (mu, xvar)

  - ( (x - mu)^2)/xvar - log(xvar)

}

.gjamBaselineHist <- function(y1, bins = NULL, ylim = NULL, 
                              htFraction = .5, nclass=20){
  
  # add histogram to base of current plot
  
  y1 <- y1[ is.finite(y1) ]
  y1[y1 < min(bins)] <- min(bins)
  y1[y1 > max(bins)] <- max(bins)
  
  if(!is.null(bins)){
    hh <- hist(y1,breaks=bins,plot=F)
  } else {
    hh <- hist(y1,nclass=nclass,plot=F)
  }
  
  xvals <- rep(hh$breaks,each=2)
  yvals <- rep(hh$density,each=2)
  
  nb    <- length(hh$breaks)
  yvals <- c( 0, yvals, 0)
  
  xy <- rbind(xvals, yvals)
  
  minx <- min(xvals)
  maxx <- max(xvals)
  miny <- min(yvals)
  dy   <- diff( range(yvals) )
  
  xy[2,] <- miny + .3*xy[2,]*dy/max(xy[2,])
  xy[1,xy[1,] < minx] <- minx
  xy[2,xy[2,] < miny] <- miny
  
  if(!is.null(ylim)){  # scale to ht of plot
    dy <- diff(ylim)
    sc <- htFraction*dy/max(xy[2,])
    xy[2,] <- ylim[1] + (xy[2,] - ylim[1])*sc
  }
  xy
}

.gjamCensorSetup <- function(y,w,z,plo,phi,wm,censorMat){
  
  nc <- ncol(censorMat)
  br <- numeric(0)
  nk <- length(wm)
  n  <- nrow(y)
  
  zk <- y[,wm]*0
  blast <- -Inf
  
  for(j in 1:nc){
    
    valuej <- censorMat[1,j]
    bj     <- censorMat[2:3,j]
    names(bj) <- paste('c-',names(bj),j,sep='')
    
    if(j > 1){
      if(censorMat[2,j] < censorMat[3,j-1] )
        stop('censor intervals must be unique')
      if(bj[1] == br[length(br)])bj <- bj[2]
    }
    br <- c(br,bj)
    nb <- length(br)
    
    zk[ y[,wm] > blast & y[,wm] < bj[1] ] <- nb - 2
    zk[ y[,wm] == valuej ] <- nb - 1
    blast <- br[length(br)]
  }
  
  if(nc == 1){
    zk[zk == 0] <- 2
    br <- c(br,Inf)
  }
  
  zk[zk == 0] <- 1
  br <- matrix(br,nk,length(br),byrow=T)
  
  censk    <- which(y[,wm] %in% censorMat[1,])
  z[,wm]   <- zk
  
  tmp   <- .gjamGetCuts(z,wm)
  cutLo <- tmp$cutLo
  cutHi <- tmp$cutHi
  
  plo[,wm] <- br[cutLo]
  phi[,wm] <- br[cutHi]
  
  ww <- which(plo[,wm,drop=F] == -Inf,arr.ind=T)
  if(length(ww) > 0){
    if(length(wm) == 1){
      mm <- w[,wm]
    }else{
      mm <- apply(w[,wm],2,max)
    }
    plo[,wm][ww] <- -10*mm[ww[,2]]
  }
  
  tmp <-  .tnorm(nk*n,plo[,wm],phi[,wm],w[,wm],1)
  
  w[,wm][censk] <- tmp[censk]
  
  imat <- w*0                    #location in full matrix
  imat[,wm][censk] <- 1
  censValue <- which(imat == 1)
  
  list(w = w, z = z, cutLo = cutLo, cutHi = cutHi, plo = plo, phi = phi,
       censValue = censValue, breakMat = br)
}

.gjamCuts2theta <- function(tg,ss){   # variance to correlation scale
  
  if(length(ss) == 1)return(tg/sqrt(ss))
  nc   <- ncol(tg)
  sr   <- nrow(ss)
  tg/matrix( sqrt(diag(ss)),sr,nc)
}

.gjamGetCuts <- function(zz,wk){
  
  nk <- length(wk)
  n  <- nrow(zz)

  cutLo <- cbind( rep(1:nk,each=n), as.vector(zz[,wk]) )
  cutHi <- cbind( rep(1:nk,each=n), as.vector(zz[,wk]) + 1 )
  
  list(cutLo = cutLo, cutHi = cutHi)
}

.gjamGetTypes <- function(typeNames=NULL){
  
  TYPES <- c('CON','PA','CA','DA','CAT','FC','CC','OC')
  FULL  <- c('continuous','presenceAbsence','contAbun','discAbun',
             'categorical','fracComp','countComp','ordinal')
  LABS  <- c('Continuous','Presence-absence','Continuous abundance',
             'Discrete abundance', 'Categorical','Fractional composition',
             'Count composition','Ordinal')
  
  if(is.null(typeNames)){
    names(FULL) <- TYPES
    return( list(typeCols = NULL, TYPES = TYPES, typeFull = FULL, 
                 labels = LABS ) )
  }
  
  S        <- length(typeNames)
  typeCols <- match(typeNames,TYPES)
  
  ww <- which(is.na(typeCols))
  if(length(ww) > 0)stop( paste('type code error',typeNames[ww],sep=' ') )
  
  list(typeCols = typeCols, TYPES = TYPES, typeFull = FULL[typeCols],
       typeNames = typeNames, labels = LABS[typeCols])
}

.gjamHoldoutSetup <- function(holdoutIndex,holdoutN,n){
  
  #holdout samples
  if(length(holdoutIndex) > 0)holdoutN <- length(holdoutIndex)
  if(holdoutN > (n/5))stop('too many holdouts')
  
  inSamples <- c(1:n)
  if(holdoutN > 0){
    if(length(holdoutIndex) == 0)holdoutIndex <- sort( sample(n,holdoutN) )
    inSamples <- inSamples[-holdoutIndex]
  }
  nIn <- length(inSamples)
  
  list(holdoutIndex = holdoutIndex, holdoutN = holdoutN, 
       inSamples = inSamples, nIn = nIn)
}

.gjamMissingValues <- function(x, y, factorList, typeNames, verbose = FALSE){
  
  n <- nrow(x)
  xnames <- colnames(x)
  
  # missing values in x
  xmiss  <- which(!is.finite(x),arr.ind=T)
  nmiss  <- nrow(xmiss)
  missX  <- missX2 <- xprior <- yprior <- numeric(0)
  
  xbound <- apply(x,2,range,na.rm=T)
  
  if(nmiss > 0){         #initialize missing values with means
    xmean    <- colMeans(x,na.rm=T)
    x[xmiss] <- xmean[xmiss[,2]]
    xprior   <- x[xmiss]
    nmiss    <- nrow(xmiss)
    fmiss    <- signif(100*nmiss/length(x[,-1]),2)
    if(verbose)
      cat( paste('\n', nmiss,' values (',fmiss,'%) missing in X imputed\n'), sep='' )
    missX <- missX2 <- rep(0,nmiss)
  }
  
  # rare y
  tmp  <- gjamTrimY(y,minObs=0,OTHER=F)
  wzo  <- which(tmp$nobs == 0)
  if(length(wzo) > 0){
    stop( ' remove from ydata types never present:',
          paste0(names(wzo),collapse=', '))
  }
  fobs <- tmp$nobs/n
  wlo  <- which(fobs < .01)
  if(length(wlo) > 0){
    flo <- paste0(names(fobs)[wlo],collapse=', ')
    if(verbose)
      cat(paste('\nPresent in < 1% of obs:',flo,'\n') )
  }
  
  # missing values in y
  ymiss <- which(!is.finite(y),arr.ind=T)
  mmiss <- nrow(ymiss)
  missY <- missY2 <- numeric(0)
  
  if(mmiss > 0){         #initialize missing values with means by TYPEs
    ymean    <- colMeans(y,na.rm=T)
    y[ymiss] <- ymean[ymiss[,2]]
    yprior   <- jitter(y[ymiss])
    fmiss    <- round(100*mmiss/length(y),1)
    mmiss <- nrow(ymiss)
    missY <- missY2 <- rep(0,mmiss)
    if(verbose)
      cat( paste('\n', mmiss,' values (',fmiss,'%) missing in Y imputed'), sep='' )
  }
  
  disTypes <- c('DA','CC','OC')
  wdd    <- which(disTypes %in% typeNames)
  if(length(wdd) > 0){
    www <- which( typeNames[ymiss[,2]] %in% disTypes )
    yprior[www] <- floor(yprior[www])
  }
  
  if(nmiss > 0){
    x[xmiss] <- xprior
    
    if(length(factorList) > 0){
      for(k in 1:length(factorList)){
        
        wm <- which(xnames[ xmiss[,2] ] == factorList[[k]][1])
        if(length(wm) == 0)next
        
        wk <- sample(length(factorList[[k]]),length(wm),replace=T)
        xtmp <- x[xmiss[wm,1],factorList[[k]],drop=F]*0
        
        xtmp[ cbind(1:nrow(xtmp),wk) ] <- 1
        x[xmiss[wm,1],factorList[[k]]] <- xtmp
      }
    }
  }
  
  if(mmiss > 0)y[ymiss] <- yprior
  
  list(xmiss = xmiss, xbound = xbound, missX = missX, missX2 = missX2,
       ymiss = ymiss, missY = missY, xprior = xprior, yprior = yprior,
       x = x, y = y)
}

.gjamPlotPars <- function(type='CA',y1,yp,censm=NULL){
  
  if(!is.matrix(y1))y1 <- matrix(y1)
  if(!is.matrix(yp))yp <- matrix(yp)
  
  n       <- nrow(y1)
  nk      <- ncol(y1)
  nbin    <- NULL
  nPerBin <- max( c(10,n*nk/15) )
  breaks  <- NULL
  xlimit  <- range(y1,na.rm=T)
  ylimit  <- range(yp,na.rm=T)
  # vlines  <- NULL
  wide    <- NULL
  MEDIAN  <- T
  LOG     <- F
  yss     <- quantile(as.vector(y1),.5, na.rm=T)/mean(y1,na.rm=T)
  
  if(type == 'CA'){
    wpos <- length( which(y1 > 0) )
    nPerBin <-  max( c(10,wpos/15) )
  }
  if(type %in% c('PA', 'CAT')){
    breaks  <- c(-.05,.05,.95,1.05)
    wide    <- rep(.08,4)
    nPerBin <- NULL
    ylimit  <- c(0,1)
    xlimit <- c(-.1,1.1)
  } 
  if(type == 'OC'){
    
    breaks  <- seq(min(y1,na.rm=T)-.5,max(y1,na.rm=T) + .5,by=1)
    wide    <- 1/max(y1)
    nPerBin <- NULL
    ylimit  <- range(yp,na.rm=T)
    xlimit  <- c( min(floor(y1),na.rm=T), max(ceiling(y1),na.rm=T) )
  } 
  if(type == 'DA')MEDIAN <- F
  if(type %in% c('DA','CA')){
    if(yss < .8){
      xlimit <- range(y1,na.rm=T)
      xlimit[2] <- xlimit[2] + 1
      LOG <- T
    }
  }
  if(type %in% c('FC','CC')){
    MEDIAN <- F
    nPerBin <- round( n*nk/50,0 )
  } 
  if(type == 'CC'){
    xlimit[2] <- xlimit[2] + 1
    if(yss <  1){
      LOG <- T
      xlimit[1] <- ylimit[1] <- 1
    }
  }
  
  if( !is.null(censm) ){
    
    cc  <- censm$partition
  #  vlines  <- numeric(0)
    breaks  <- NULL
    nPerBin <- n*nk/15
    xlimit  <- range(y1,na.rm=T)
    ylimit  <- quantile(yp,c(.01,.99),na.rm=T)
    
    if(ncol(cc) > 1){
      cm     <- unique( as.vector(cc[-1,]) )
      breaks <- cm[is.finite(cm)]
      nbin   <- nPerBin <- NULL
      uncens <- cbind(cc[3,-ncol(cc)],cc[2,-1])
      wu     <- which( uncens[,1] != uncens[,2] )
      for(m in wu){
        sm <- seq(uncens[m,1],uncens[m,2],length=round(10/length(wu),0))
        if(type == 'DA') sm <- c(uncens[m,1]:uncens[m,2])
        breaks <- c(breaks,sm)
      }
      if(max(cc[1,]) < Inf){
        breaks <- c(breaks, seq(max(breaks),(max(y1,na.rm=T)+1),length=12) )
      } else {
        breaks <- c(breaks,max(y1,na.rm=T) + 1)
      }
      breaks <- sort( unique(breaks) )
    }
  }
  
  if(LOG){
    xlimit[1] <- ylimit[1] <- quantile(y1[y1 > 0],.001, na.rm=T)
    w0     <- which(y1 == 0)
    y1[w0] <- ylimit[1]
    w0     <- which(yp == 0)
    yp[w0] <- ylimit[1]
    ylimit[2] <- max(yp,na.rm=T)
  }
  
  list( y1 = y1, yp = yp, nbin=nbin, nPerBin=nPerBin, # vlines=vlines,
        xlimit=xlimit,ylimit=ylimit,breaks=breaks,wide=wide,LOG=LOG,
        POINTS=F,MEDIAN=MEDIAN )
}

.gjamPredictTraits <- function(w,specByTrait,traitTypes){
  
  M  <- nrow(specByTrait)
  tn <- rownames(specByTrait)
  
  ww <- w
  ww[ww < 0] <- 0
  
  ww%*%t(specByTrait)
}

.initW <- function(tw, x, yy, minw = -ncol(yy), cat=F){
  
  # initialize w for y = 0
  
  X <- x
  X[,-1] <- jitter(X[,-1],factor=1)
  
  XX  <- crossprod(X)
  
  IXX <- solveRcpp(XX)
  
  for(j in 1:50){
    
    bb <- IXX%*%crossprod(X,tw)
    muw <- X%*%bb
    
    tw[yy == 0] <- muw[yy == 0]    #neg values 
    tw[yy == 0 & tw > 0] <- 0      #no bigger than zero
  }
  tw[tw < minw] <- minw
  tw
}


.gjamSetup <- function(typeNames, x, y, breakList=NULL, holdoutN, holdoutIndex,
                       censor=NULL, effort=NULL, maxBreaks=1000 ){
   
  Q <- ncol(x)
  n <- nrow(y)
  S <- ncol(y)
  
  effMat <- effort$values

  tmp <- .gjamGetTypes(typeNames)
  typeFull <- tmp$typeFull
  typeCols <- tmp$typeCols
  allTypes <- unique(typeCols)
  
  cuts <- cutLo <- cutHi <- numeric(0)
  minOrd <- maxOrd <- breakMat <- numeric(0)
  
  ordShift <- NULL
  
  ordCols  <- which(typeNames == 'OC')
  disCols  <- which(typeNames == 'DA')
  compCols <- which(typeNames == 'CC')
  corCols  <- which(typeNames %in% c('PA','OC','CAT'))
  catCols  <- which(typeNames == c('CAT'))
  
  CCgroups <- attr(typeNames,'CCgroups')
  if(length(CCgroups) == 0)CCgroups <- rep(0,S)
  ngroup <- max(CCgroups)
  
  FCgroups <- attr(typeNames,'FCgroups')
  if(length(FCgroups) == 0)FCgroups <- rep(0,S)
  fgroup <- max(FCgroups)
  
  CATgroups <- attr(typeNames,'CATgroups')
  if(length(CATgroups) == 0)CATgroups <- rep(0,S)
  cgroup <- max(CATgroups)
  
  wo <- grep('others',colnames(y))
  if(length(wo) > 0){
    colnames(y)[wo] <- .replaceString(colnames(y)[wo],'others','other')
  }
  
  other <- grep('other',colnames(y))
  
  colnames(y) <- .cleanNames(colnames(y))
  
  w  <- y 
  if( !is.null(effort) )w <- w/effort$values
  
  maxy <- apply(w,2,max,na.rm=T)
  miny <- apply(w,2,min,na.rm=T)
  miny[miny > -maxy] <- -maxy[miny > -maxy]
  maxy[maxy < 0] <- -maxy[maxy < 0]
  maxy <- matrix(maxy, n, S, byrow=T)
  
  z  <- w*0
  z[y == 0] <- 1
  z[y > 0]  <- 2
  plo <- phi <- y*0
  plo[z == 1] <- -maxy[z == 1]/2
  phi[z == 2] <- 2*maxy[z == 2]
  
  censorCON <- censorCA <- censorDA <- numeric(0) # values to be sampled
  sampleW  <- y*0
  sampleW[is.na(sampleW)] <- 1
  
  for(k in allTypes){
    
    wk <- which(typeCols == k)
    nk <- length(wk)
    
    if( typeFull[wk[1]] == 'presenceAbsence' ){       
      
      sampleW[,wk] <- 1
      plo[,wk][z[,wk] == 1] <- -3
      phi[,wk][z[,wk] == 2] <- 3
      
      w[,wk] <- .tnorm(nk*n,plo[,wk],phi[,wk],0,1)
      br <- c(-3,0,3)
      br <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('PA',wk,sep='-')
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat     <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] == 'continuous' ){      
      
      sampleW[,wk] <- 0
      z[,wk]   <- 1
      plo[,wk] <- -2*maxy[,wk]
      phi[,wk] <- 2*maxy[,wk]
      
      if( !is.null(censor) & 'CON' %in% names(censor) ){
        
        wc     <- which(names(censor) == 'CON')
        bc     <- censorCON <- numeric(0)
        
        for(m in wc){
          
          wm     <- censor[[m]]$columns
          cp     <- censor[[m]]$partition
          for(ii in 1:ncol(cp)){
            wmm <- which( y[,wm] == cp[1,ii] | (y[,wm] > cp[2,ii] & y[,wm] < cp[3,ii]) )
            mmm <- cp[2,ii]
            if(mmm == -Inf)mmm <- cp[3,ii] - 10
            censor[[m]]$partition[2,ii] <- mmm
            plo[,wm][wmm] <- mmm
            phi[,wm][wmm] <- cp[3,ii]
          }
          
          tmp    <- .gjamCensorSetup(y,w,z,plo,phi,wm,censorMat=
                                       censor[[m]]$partition)
          z[,wm] <- tmp$z[,wm]
          censorCON <- c(censorCON,tmp$censValue)
          bt       <- tmp$breakMat
          colnames(bt) <- as.character(c(1:ncol(bt)))
          rownames(bt) <- paste('CA',wm,sep='-')
          
          bc <- .appendMatrix(bc,bt,SORT=T,asNumbers=T)
        }
      }
      
      br <- c(-Inf,-Inf,Inf)
      br  <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('CON',wk,sep='-')
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] == 'contAbun' ){       
      
      phi[,wk] <- 2*maxy[,wk]
      plo[,wk] <- -phi[,wk]/4
      
      wy1 <- which(y[,wk] > 0)
      
      w[,wk][wy1] <- y[,wk][wy1]
      
      
      wy0 <- which(y[,wk] == 0)
      phi[,wk][wy0] <- 0
      
      w[,wk] <- .initW(w[,wk], x, y[,wk], minw = -max(y[,wk],na.rm=T)*5)
      w[,wk][wy1] <- y[,wk][wy1]
      
      br <- c(-Inf,0,Inf)
      br  <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('CA',wk,sep='-')
      
      sampleW[,wk][y[,wk] == 0] <- 1
      
      if( !is.null(censor) & 'CA' %in% names(censor) ){
        
        wc     <- which(names(censor) == 'CA')
        bc     <- censorCA <- numeric(0)
        
        for(m in wc){
          
          wm     <- censor[[m]]$columns
          cp     <- censor[[m]]$partition
          for(ii in 1:ncol(cp)){
            wmm <- which(y[,wm] == cp[1,ii] | (y[,wm] > cp[2,ii] & y[,wm] < cp[3,ii]) )
            plo[,wm][wmm] <- cp[2,ii]
            phi[,wm][wmm] <- cp[3,ii]
          }
          
          tmp    <- .gjamCensorSetup(y,w,z,plo,phi,wm,censorMat=
                                       censor[[m]]$partition)
          z[,wm] <- tmp$z[,wm]
          censorCA <- c(censorCA,tmp$censValue)
          bt       <- tmp$breakMat
          colnames(bt) <- as.character(c(1:ncol(bt)))
          rownames(bt) <- paste('CA',wm,sep='-')
          
          bc <- .appendMatrix(bc,bt,SORT=T,asNumbers=T)
        }
        
        mm <- match(rownames(bc),rownames(br))
        
        if(is.na(min(mm)))stop('error in censor list, check for conflicts')
        
        bb <- br[-mm,]
        tmp <- .appendMatrix(bc,bb,SORT=T,asNumbers=T)
        o   <- as.numeric( matrix( unlist(strsplit(rownames(tmp),'-')),
                                   ncol=2,byrow=T)[,2] ) 
        br <- tmp[drop=F,order(o),]
      }
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] == 'discAbun' ){
      
      plo[,wk] <- (y[,wk] - .5)/effMat[,wk]
      plo[,wk][y[,wk] == 0] <- -.5*maxy[,wk][y[,wk] == 0] 
      phi[,wk] <- (y[,wk] + .5)/effMat[,wk]
      
      sampleW[,wk] <- 1
      
      disCols <- wk
      
      z[,wk] <- y[,wk] + 1
      w[,wk] <- .tnorm(nk*n,plo[,wk],phi[,wk],w[,wk],1)
      
      n <- nrow(y)
      S <- ncol(y)
      
      mx <- max(y[,wk]) - 1
      br <- c( -Inf, seq(0, mx), Inf) 
 
      br <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('DA',wk,sep='-')
      
      if( !is.null(censor) & 'DA' %in% names(censor) ){
        
        wc     <- which(names(censor) == 'DA')
        bc     <- censorDA <- numeric(0)
        
        for(m in wc){
          wm     <- censor[[m]]$columns
          tmp    <- .gjamCensorSetup(y,w,z,plo,phi,wm,
                                     censorMat=censor[[m]]$partition)
          w[,wm] <- tmp$w[,wm]
          z[,wm] <- tmp$z[,wm]
          plo[,wm] <- tmp$plo[,wm]
          phi[,wm] <- tmp$phi[,wm]
          censorDA <- c(censorDA,tmp$censValue)
          bt       <- tmp$breakMat
          colnames(bt) <- as.character(c(1:ncol(bt)))
          rownames(bt) <- paste('DA',wm,sep='-')
          
          bc <- .appendMatrix(bc,bt,SORT=T,asNumbers=T)
        }
        mm <- match(rownames(bc),rownames(br))
        
        bb <- br[-mm,]
        tmp <- .appendMatrix(bc,bb,SORT=T,asNumbers=T)
        o   <- as.numeric( matrix( unlist(strsplit(rownames(tmp),'-')),
                                   ncol=2,byrow=T)[,2] ) 
        br <- tmp[order(o),]
      }
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] == 'fracComp' ){
      
      wss <- which(y[,wk] == 0 | y[,wk] == 1)
      sampleW[,wk][wss] <- 1
      
      for(i in 1:fgroup){
        
        if(fgroup == 1){
          wki <- wk
        } else {
          wki <- which(typeCols == k & FCgroups == i)
        }
        nki <- length(wki)
        yki  <- y[,wki]
        
        lo <- plo[,wki]
        hi <- phi[,wki]
        lo[lo < -200/S] <- -200/S
        hi[hi > 3]  <- 3
        plo[,wki] <- lo
        phi[,wki] <- hi
        
        w[,wki] <- .initW(w[,wki], x, yki, minw = -200/S)
      }
      
      br <- c(-1,0,1)
      br <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('FC',wk,sep='-')
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] %in% c('countComp','categorical')){
      
      sampleW[,wk] <- 1
      
      ntt <- ngroup
      if(typeFull[wk[1]] == 'categorical')ntt <- cgroup
      
      for(i in 1:ntt){
        
        if(ntt == 1){
          wki <- wk
        } else {
          wki <- which( typeCols == k )
          wki <- wki[ CCgroups[wki] == i | CATgroups[wki] == i ]
        }
        nki <- length(wki)
        yki  <- y[,wki]
        
        if( wki[1] %in% catCols ){
          lo  <- hi <- yki*0
          lo[yki == 0] <- -100
          hi[yki == 0] <- 0
          hi[yki == 1] <- 100
          mu <- yki*0
          mu[lo == 0] <- 20
          mu[hi == 0] <- -20
        } else {
          ee <- rowSums(yki)  + 1
          lo <- (yki - .5)/ee          
          hi <- (yki + .5)/ee
          lo[lo < 0]  <- -20/S
          mu <- yki/ee
        }
        
        z[,wki] <- yki + 1
        
        plo[,wki] <- lo
        phi[,wki] <- hi
        
        tmp <- matrix( .tnorm(nki*n,as.vector(lo),as.vector(hi), as.vector(mu), sig=5),n,nki )
        
        tt <- tmp
        if( !wki[1] %in% catCols ){
          tt[tt < 0] <- 0
          tsum <- rowSums(tt)
          tt   <- sweep(tt,1,tsum,'/')
          tt[tmp < 0] <- tmp[tmp < 0]
        }
        w[,wki] <- tt
      }
      
      br <- c(-1,0,1)
      br <- matrix(br,nk,length(br),byrow=T)
      colnames(br) <- as.character(c(1:ncol(br)))
      rownames(br) <- paste('CC',wk,sep='-')
      rownames(br) <- paste(colnames(y)[wk],rownames(br),sep='_')
      breakMat <- .appendMatrix(breakMat,br,SORT=T,asNumbers=T)
    }
    
    if( typeFull[wk[1]] == 'ordinal' ){
      
      miny <- ordShift <- apply(y[,wk,drop=F],2,min)
      
      y[,wk] <- y[,wk] - matrix(miny,n,nk,byrow=T)   #min value is zero 
      
      nc <- apply(y[,wk,drop=F],2,max)
      
      sampleW[,wk] <- 1
      
      # more than one obs needed in last cell to estimate partition
      ii  <- list(spec = as.vector(matrix(c(1:nk),n,nk,byrow=T)), 
                  ss = as.vector(y[,wk,drop=F]))
      
      ctmp <- tapply(as.vector(y[,wk,drop=F])*0+1,ii,sum)
      ccol <- range( as.numeric(colnames(ctmp)) )
      ccol <- ccol[1]:ccol[2]
      
      ct <- matrix(0, nrow(ctmp), length(ccol), 
                   dimnames = list(rownames(ctmp), ccol) )
      ct[rownames(ctmp),colnames(ctmp)] <- ctmp
      ct[ is.na(ct) ] <- 0
      ctmp <- ct
      
      ncc <- nc + 1
      if(max(ncc) > ncol(ctmp))ncc <- nc
      
      maxOne <- which(ctmp[ cbind(1:nk,ncc) ] == 1)
      
      if(length(maxOne) > 0){

        for(m in 1:length(maxOne)){
          mc <- wk[maxOne[m]]
          y[y[,mc] == nc[maxOne[m]],mc] <- nc[maxOne[m]] - 1
        }
        nc <- apply(y[,wk,drop=F],2,max)
      }
      
      ncut <- max(y[,wk,drop=F])
      crow <- c(0:ncut)
      cuts <- t( matrix(crow,(ncut+1),nk) )
      cuts[ cbind((1:nk),nc+1) ] <- Inf
      
      call <- t( apply(cuts,1,cumsum) )
      cuts[call == Inf] <- Inf
      cuts <- cbind(-Inf,cuts)
      if(!is.matrix(cuts))cuts <- matrix(cuts,1)
    
      tmp   <- .gjamGetCuts(y + 1,wk)
      cutLo <- tmp$cutLo
      cutHi <- tmp$cutHi
      
      ss   <- seq(0,(nk-1)*n,by=n)
      wh <- as.vector( outer(holdoutIndex,ss,'+') )
      c1 <- cutLo
      if(length(wh) > 0)c1 <- cutLo[-wh,]

      otab <- .byIndex(c1[,1]*0 + 1,INDICES=list('i'=c1[,1],
                                                 'j'=c1[,2]),sum,coerce=T)
      oo <- cbind(0,t( apply(otab,1,cumsum) ))
      wo <- which(oo == 0,arr.ind=T)
      wo[,2] <- as.numeric(colnames(otab))[wo[,2]]
      minOrd <- .byIndex(wo[,2],wo[,1],max)
      
      oo <- cbind(0,t( apply( t(apply(otab,1,rev)),1,cumsum) ))
      wo <- which(oo == 0,arr.ind=T)
      maxOrd <- ncut - .byIndex(wo[,2],wo[,1],max) + 2
      
      plo[,wk] <- cuts[cutLo]
      phi[,wk] <- cuts[cutHi]
      
      z[,wk] <- y[,wk] + 1
      w[,wk] <- matrix( .tnorm(nk*n,plo[,wk],phi[,wk],y[,wk],1),n,nk )
      
      colnames(cuts) <- c(1:ncol(cuts))
      rownames(cuts) <- paste('OC',wk,sep='-')
      rownames(cuts) <- paste(colnames(y)[wk],rownames(cuts),sep='_')
      breakMat <- .appendMatrix(breakMat,cuts,SORT=T,asNumbers=T)
    }
  }
  sord <- .splitNames(rownames(breakMat))$vnam[,1]
  yord <- match(colnames(y),sord)
  breakMat <- breakMat[yord,]
  
  sampleW[censorCON] <- 1
  sampleW[censorCA] <- 1
  sampleW[censorDA] <- 1
  
  wCols <- which(colSums(sampleW) > 0)
  wRows <- which(rowSums(sampleW) > 0)
  
  attr(sampleW,'type') <- 'cols'
  attr(sampleW,'index') <- wCols
  if( sum(sampleW) == 0)attr(sampleW,'type') <- 'none'
  if( sum(sampleW) > 0 & (length(wRows) < length(wCols)) ){
    attr(sampleW,'type') <- 'rows'
    attr(sampleW,'index') <- wRows
  }
  
  ii <- list(spec = as.vector(matrix(c(1:S),n,S,byrow=T)), 
             discrete_class = as.vector(z))
  classBySpec <- .byIndex(as.vector(z)*0+1,ii,sum)
  rownames(classBySpec) <- colnames(y)
  
  ncc <- min(20,ncol(classBySpec))
  nrr <- min(20,nrow(classBySpec))
  
    list(w = w, z = z, y = y, other = other, cuts = cuts, 
         cutLo = cutLo, cutHi = cutHi, ordShift = ordShift,
         plo = plo, phi = phi, ordCols=ordCols, disCols = disCols, 
         compCols = compCols, corCols = corCols,
         classBySpec = classBySpec, breakMat = breakMat, 
         minOrd = minOrd, maxOrd = maxOrd, sampleW = sampleW,
         censorCA = censorCA, censorDA = censorDA, censorCON = censorCON )
 }

.gjamTrueVest <- function( pchains, true, typeCode, allTypes, xlim=NULL, ylim=NULL,
                          label=NULL, colors=NULL, add=F, legend=T){
  
  ntypes <- length(allTypes)
  
  if(is.null(ylim))ylim <- quantile(pchains, c(.025, .975), na.rm=T)
  if(is.null(xlim))xlim <- range(true,na.rm=T)
  
  if( !is.matrix(pchains) ){
    pchains <- matrix(pchains,ncol=1)
    bCoeffTable <- c(mean(pchains),sd(pchains),quantile(pchains,c(.025,.975)),true)
    bCoeffTable <- matrix(bCoeffTable,1)
  } else {
    bCoeffTable <- .chain2tab( pchains, colnames(true), rownames(true) )
  }
  
  if(is.null(colors)){
    colors <- 1
    if(ntypes > 1)colors <- typeCode
  }
  if(length(colors) == 1) colors <- rep(colors,ntypes)
  
  if(is.matrix(true)){
  
  tlabs <- outer(rownames(true), colnames(true), paste, sep='_')
  
  mm <- match(tlabs, colnames(pchains))
  wn <- which( !is.finite(mm) )
  if(length(wn) > 0){
    
    tlabs <- t( outer(colnames(true), rownames(true), paste, sep='_') )
    mm <- match(tlabs, colnames(pchains))
    wn <- which( !is.finite(mm) )
    
  }
  tvec <- as.vector(true)
  names(tvec) <- as.vector(tlabs)
  tvec <- tvec[ match( colnames(pchains), names(tvec)  ) ]
  }else{
    tvec <- true
  }
  
  .predVsObs(tvec, p=pchains, xlab='true', xlim=xlim, ylim=ylim, ylab='estimated',
            colors=colors,add=add)
  
  if(ntypes > 1 & legend)legend('topleft',allTypes,text.col=colors,bty='n')
  if(!is.null(label)).plotLabel(label,above=T)
  
  invisible( bCoeffTable )
}

.conditionalMVN <- function( xx, mu, sigma, cdex, p=ncol(mu) ){  
  # xx, mu are matrices
  # cdex conditional for these variables, must come last
  # gdex condition on these variables
  
  if(ncol(xx) != ncol(sigma))stop('ncol(xx) != ncol(sigma)')
  if(ncol(mu) != ncol(sigma))stop('ncol(mu) != ncol(sigma)')
  if(max(cdex) > ncol(mu))stop('max(cdex) > ncol(mu)')
  
  # new order
  ci   <- (1:p)[-cdex]
  new  <- c(ci, cdex)
  cnew <- match(cdex, new)
  pnew <- 1:(p - length(cnew))
  
  cond <- try( 
    condMVNRcpp(cnew-1, pnew-1, xx[,new, drop=F], 
                mu[,new, drop=F], sigma[new,new]), T)
  
  if( !inherits( cond,'try-error') ){
    return(cond)
    
  }else{
    
    sinv <- solve( sigma[drop=F, pnew, pnew] )
    p1   <- sigma[drop=F, cnew,pnew]%*%sinv
    mu1  <- mu[drop=F, ,cnew] + t( p1%*%t( xx[drop=F, ,pnew] - mu[drop=F, ,pnew] ) )
    vr1 <- solveRcpp( sinv[drop=F, cnew, cnew] )
    
    return( list( mu = mu1, vr = vr1 ) )
  }
}

checkCondDistribution <- function(xx, mu, sigma, cond ){
  
  p <- ncol(mu)
  condOn <- c(1:p)[-cond]
  
  s1 <- sigma[drop=F,cond, condOn]%*%solve(sigma[drop=F,condOn,condOn])
  mm <- mu[drop=F,,cond] + t( s1%*%t(xx[drop=F,,condOn] - mu[drop=F,,condOn]) )
  vr <- sigma[drop=F,cond,cond] - s1%*%sigma[drop=F,condOn,cond]
  return( list( mu = mm, vr = vr ) )
}

.conditionalMVNRcpp <- function( xx, mu, sigma, cdex, p=ncol(mu) ){  # not used, see .conditionalMVN
  # xx, mu are matrices
  # cdex conditional for these variables, must come last
  # gdex condition on these variables
  
  if(ncol(xx) != ncol(sigma))stop('ncol(xx) != ncol(sigma)')
  if(ncol(mu) != ncol(sigma))stop('ncol(mu) != ncol(sigma)')
  if(max(cdex) > ncol(mu))stop('max(cdex) > ncol(mu)')
  
  # new order
  ci   <- (1:p)[-cdex]
  new  <- c(ci, cdex)
  cnew <- match(cdex, new)
  pnew <- 1:(p - length(cnew))
   
  condMVNRcpp(cnew-1, pnew-1, xx[,new, drop=F], mu[,new, drop=F], sigma[new,new]) 
}

  


.byGJAM <- function(x, i, j, summat=matrix(0,max(i),max(j)), 
                   totmat=summat, fun='mean'){  #
  
  nn <- length(x)
  if( nn != length(i) | nn != length(j) )
    stop('vectors unequal in byFunctionRcpp')
  if( nrow(summat) < max(i) | ncol(summat) < max(j) )
    stop('matrix too small')
  
  ww <- which(is.na(x))
  if(length(ww) > 0){
    x <- x[-ww]
    i <- i[-ww]
    j <- j[-ww]
  }
  
  frommat <- cbind(i,j,x)
  
  nr  <- nrow(frommat)
  
  maxmat <- summat*0 - Inf
  minmat <- summat*0 + Inf
  
  tmp <- byRcpp(nr, frommat, totmat, summat, minmat, maxmat)
  
  if(fun == 'sum')return(tmp$sum)
  if(fun == 'mean'){
    mu <- tmp$sum/tmp$total
    mu[is.na(mu)] <- 0
    return(mu)
  }
  if(fun == 'min'){
    return( tmp$min )
  }
  tmp$max
}

.tnormMVNmatrix <- function(avec, muvec, smat, 
                                lo=matrix(-1000,nrow(muvec),ncol(muvec)), 
                                hi=matrix(1000,nrow(muvec),ncol(muvec)),
                                whichSample = c(1:nrow(smat)) ){
  
  #lo, hi must be same dimensions as muvec,avec
  
  lo[lo < -1000] <- -1000
  hi[hi > 1000]  <- 1000
  
  if(max(whichSample) > length(muvec))
    stop('whichSample outside length(muvec)')
  
  r <- avec
  a <- trMVNmatrixRcpp(avec, muvec, smat, lo, hi, whichSample, 
                              idxALL = c(0:(nrow(smat)-1)) )  
  r[,whichSample] <- a[,whichSample]
  r
}

.whichFactor <- function(dframe){
  
  if(!is.data.frame(dframe))return(character(0))
  
  tmp <- model.frame(data = dframe)
  ym <- attr( attributes(tmp)$terms, 'dataClasses' )
  
  which(ym == 'factor')
}

.xpredSetup <- function(Y, xx, bgg, isNonLinX, factorObject, intMat, standMatSd, standMatMu,
                        notOther, notStandard ){
  
  isFactor   <- factorObject$isFactor
  factorList <- factorObject$factorList
  linFactor  <- numeric(0)
  
  Q      <- ncol(xx)
  if(Q == 1){
    return( list(linFactor = linFactor, xpred = xx, px = 1, 
                 lox = 1, hix = 1) )
  }
  
  # initialize predicted X
  
  xpred  <- xx
  n      <- nrow(xx)
 
  xpnames <- colnames(xx)
  SO     <- length(notOther)
  
  px <- 1:Q
  if(length(isNonLinX) > 0)px <- px[-isNonLinX]
  px <- px[!xpnames[px] %in% isFactor]
  px <- px[px != 1]
  
  ii <- grep(':',xpnames,fixed=T)
  i2 <- grep('^2',xpnames,fixed=T)
  
  qx <- c( 1, ii, i2)
  qx <- c(1:Q)[-qx]
  
  bx <- solveRcpp( crossprod(xx[,qx,drop=F]) )%*%crossprod(xx[,qx,drop=F], Y[,notOther])
  
  cx <- crossprod(t(bx))
  if(length(cx) == 1){
    cx <- 1/(cx*1.01)
  } else {
    diag(cx) <- .0000001 + diag(cx) 
    cx <- solveRcpp(cx)
  }
  
  xk <- (Y[,notOther] - matrix(bgg[1,notOther],n,SO,byrow=T))%*%t(bx)%*%cx
  colnames(xk) <- xpnames[qx]
  scol       <- colnames(xk)[!colnames(xk) %in% notStandard]
  xk[,scol]  <- sweep(xk[,scol,drop=F],2,colMeans(xk[,scol,drop=F]),'-')
  xk[,scol]  <- sweep(xk[,scol,drop=F],2,apply(xk[,scol,drop=F],2,sd),'/')
  xpred[,qx] <- xk
  
  xmu <- apply(xx, 2, sd)
  xse <- apply(xx, 2, sd)
  
  propx <- xse/10
  
  lo <- xmu - 3*xse
  hi <- xmu + 3*xse
  
  xl <- matrix( lo, nrow(xpred), ncol(xpred), byrow=T)
  xh <- matrix( hi, nrow(xpred), ncol(xpred), byrow=T)
  
  xpred[xpred < xl] <- xl[xpred < xl]
  xpred[xpred > xh] <- xh[xpred > xh]
  xpred[!is.finite(xpred)] <- 0
  
  rm(xl, xh)
  
  if(length(intMat) > 0){
    for(k in 1:nrow(intMat)){
      xpred[,intMat[k,1]] <- xpred[,intMat[k,2]]*xpred[,intMat[k,3]]
    }
  }
  
  if(length(isFactor) > 0){
    xpred[,isFactor] <- 0
    
    for(k in 1:length(factorList)){
      kf  <- lf <- factorList[[k]]
      
      if( !is.null(isNonLinX) ){
        xin <- xpnames[isNonLinX]
        lf  <- kf[!kf %in% xin]
      }
      if(length(lf) == 0)next
      lf  <- match(lf,xpnames)
      ww  <- which(is.finite(lf))
      
      wt  <- colSums(xx[,c(1,lf)])   #random, but weighted by prevalence
      wt  <- wt/sum(wt)
      sk  <- sample(c(1,lf),n, replace=T, prob=wt)
      xpred[ cbind(c(1:n),sk) ] <- 1
      
      if(length(ww) == 0)next
      lf <- c(1,lf)   # intercept is reference
      linFactor <- append(linFactor, list(lf))
      names(linFactor)[length(linFactor)] <- names(factorList)[k]
    }
  }
  
  lox       <- apply(xx,2 ,min)
  hix       <- apply(xx,2, max)
  
  lox[isFactor] <- -3
  hix[isFactor] <- 3
  if(length(intMat) > 0){
    lox[intMat[,1]] <- -3
    hix[intMat[,1]] <- 3
  }
  
  if( length(notStandard) > 0 ){
    ws        <- which(notStandard %in% xpnames)
    if(length(ws) == 0){
      notStandard <- NULL
    } else {
      notStandard <- notStandard[ws]
      lox[notStandard] <- standMatMu[notStandard,1] - 3*standMatSd[notStandard,1]
      hix[notStandard] <- standMatMu[notStandard,1] + 3*standMatSd[notStandard,1]
    }
  }
  
  list(linFactor = linFactor, xpred = xpred, px = px, 
       propx = propx, lox = lox, hix = hix)
}

.blockDiag <- function(mat1,mat2){
  
  #creates block diagional
  
  if(length(mat1) == 0)return(mat2)
  
  namesc <- c(colnames(mat1),colnames(mat2))
  namesr <- c(rownames(mat1),rownames(mat2))
  
  nr1 <- nrow(mat1)
  nr2 <- nrow(mat2)
  nc1 <- ncol(mat1)
  nc2 <- ncol(mat2)
  nr  <- nr1 + nr2
  nc  <- nc1 + nc2
  
  new <- matrix(0,nr,nc)
  new[ 1:nr1, 1:nc1 ] <- mat1
  new[ (nr1+1):nr, (nc1+1):nc ] <- mat2
  colnames(new) <- namesc
  rownames(new) <- namesr
  new
}

.getContrasts <- function(facK, fnames){
  
  # D - x to z
  # L - beta to alpha
  # facK - name of factor
  # fnames - character of factor levels
  
  ff <- paste(facK,fnames,sep='')
  
  Q  <- length(fnames)
  cc <- diag(Q)
  cc[1,] <- -1
  dd <- cc
  dd[1] <- 1
  cc[,1] <- 1
  colnames(cc) <- colnames(dd) <- c('intercept',ff[-1])
  rownames(cc) <- rownames(dd) <- fnames
  L <- t( solve(cc) )
  rownames(cc) <- rownames(L) <- rownames(dd) <- ff
  list(C = cc, D = dd, L = L)
}


.getUnstandX <- function(formula, xs, xdata, standRows ){
  
  # x is standardized for columns standRows
  # create an unstandardized version of x
  
  if(length(standRows) == 0)return( list( xu = xs, S2U = diag( ncol(xs)) ) )
  
  tmp      <- model.frame(formula, data = xdata, na.action=NULL)
  xUnstand <- model.matrix(formula, data=tmp)
  colnames(xUnstand)[1] <- 'intercept'
  
  wna <- unique( which(is.na( xUnstand ), arr.ind=T)[,1] )
  
  xu <- xUnstand
  if(length(wna) > 0){
    xs <- xs[-wna,]
    xu <- xu[-wna,]
  }
  
  s2u <- solveRcpp( crossprod(xu) )%*%crossprod(xu,xs)
  rownames(s2u) <- colnames(xs)
  s2u[ abs(s2u) < 1e-12 ] <- 0
  
  list(xu = xUnstand, S2U = s2u)
}

.getStandX <- function(formula, xu, standRows, xmu = NULL, xsd = NULL, verbose = F){
  
  # xu is unstandardized
  # xdataStand is xdata with standardized columns
  # standardize only columns in standRows using xmu, xsd
  
  if( length(standRows) == 0 ){
    xs <- model.matrix(formula, data.frame(xu) )
    colnames(xs)[1] <- 'intercept'
    return( list(xstand = xs, xdataStand = xu, xmu = xmu, xsd = xsd,
                                           U2S = diag(ncol(xs)) ) )
  }
  
  xu <- xdataStand <- as.data.frame( xu )
  
  inCols <- colnames(xu)
  ifact  <- which( sapply(data.frame(xu), is.factor) )
  
  if( is.null(xmu) )xmu <- colMeans(xu[,standRows, drop=F], na.rm=T)
  if( is.null(xsd) )xsd <- apply(xu[,standRows, drop=F], 2, sd, na.rm=T)
  
  xs  <- xu
  wna <- which( sapply(xu, is.na), arr.ind=T )
  
  wni <- which(wna[,2] %in% ifact)
  if( length(wni) > 0 ){
    wni <- wna[wni,]
    wna <- wna[-wni,]    
    
    #   stop('cannot have NA in factor levels')
  }
  wna <- which( is.na(xu[,standRows]), arr.ind=T )
  
  if( length(wna) > 0 ){                 # temporarily NA to means
    
    xs[,standRows][ wna ] <- xmu[ wna[,2] ]
    xu[,standRows][ wna ] <- xmu[ wna[,2] ]
    
    if( length(wni) > 0 ){
      
      fcol <- unique( wni[,2] )
      
      for( m in fcol ){
        mf <- levels(xu[,m])[1]
        wm <- wni[ wni[,2] == m, ]
        xu[ wm ] <- mf
      }
    }
  }
  
  sc <- standRows
  if( !is.character(sc) )sc <- names( standRows )
  
  xs[, sc] <- t( ( t( xs[, sc, drop = F] ) - xmu[sc] )/xsd[sc] )
  
  xdataStand[,sc] <- xs[,sc, drop=F] # xdata with standardized columns
  
  xs <- model.matrix(formula, data.frame(xs) )
  colnames(xs)[1] <- 'intercept'
  
  xu <- model.matrix(formula, xu )   # unstandardized
  colnames(xs)[1] <- colnames(xu)[1] <- 'intercept'
  
  bigSD <- apply(xs, 2, range)
  wk <- which( abs(bigSD) > 20, arr.ind=T )
  if( length(wk) > 0){
    b <- paste0( colnames(bigSD)[wk[,2]], collapse=', ' )
    toConsole( '\nNote: Values in x more than 20 SDs from the mean of fitted data', b, verbose )
    FLAG <- T
  }
  
  XX  <- crossprod( xs )
  ssx <- try( solveRcpp( XX ), T )
  
  if( inherits( ssx,'try-error') ){
    u2s <- diag( ncol(xs) )
    attr(u2s, 'valid' ) <- FALSE
  }else{
    u2s <- ssx%*%crossprod(xs,xu) # bs <- u2s%*%bu
    u2s[ abs(u2s) < 1e-10 ] <- 0
    attr(u2s, 'valid' ) <- TRUE
  }
  rownames(u2s) <- colnames(xs)
  colnames(u2s) <- colnames(xu)
  
  if( length(wna) > 0 ){        # replace NA
    xs[ wna ] <- 0
    xdataStand[ wna ] <- NA
  }

  list(xstand = xs, xdataStand = xdataStand, xmu = xmu, xsd = xsd, U2S = u2s)
}
  
.getHoldLoHi <- function(yh, wh, pl, ph, eff, ymax, typeNames, cutg, ordCols){
  
  # update plo, phi for holdouts, yh is prediction
  
  allTypes <- unique(typeNames)
  
  for(k in 1:length(allTypes)){
    
    tk <- allTypes[k]
    wk <- which(typeNames == tk)
    
    if(tk == 'CON')next
    
    if(tk == 'PA'){
      pl[,wk][yh[,wk] == 0] <- -10
      pl[,wk][yh[,wk] == 1] <- 0
      ph[,wk][yh[,wk] == 0] <- 0
      ph[,wk][yh[,wk] == 1] <- 10
    }
    if(tk == 'CA'){
      ym <- max(ymax[wk])
      pl[,wk][yh[,wk] == 0] <- -5*ym
      pl[,wk][yh[,wk] > 0]  <- 0
      ph[,wk][yh[,wk] == 0] <- 0
      ph[,wk][yh[,wk] > 0] <- 5*ym
    }
    if(tk == 'DA'){
      ym <- max(ymax[wk])
      ee <- 1
      if(!is.null(eff))ee <- eff[,wk]
      pl[,wk] <- (yh[,wk] - .5)/ee
      ph[,wk] <- (yh[,wk] + .5)/ee
      pl[,wk][yh[,wk] == 0] <- -5*ym
      pl[,wk][yh[,wk] == ym] <- 5*ym
    }
    if(tk == 'FC'){
      pl[,wk][yh[,wk] == 0] <- -5
      pl[,wk][yh[,wk] > 0]  <- 0
      pl[,wk][yh[,wk] > 1]  <- 1
      ph[,wk][yh[,wk] == 0] <- 0
      ph[,wk][yh[,wk] > 0]  <- 1
      ph[,wk][yh[,wk] == 1] <- 5
    }
    if(tk == 'CC'){
      ym <- rowSums(yh[,wk,drop=F])
      ee <- matrix(ym,nrow(yh),length(wk))
      pl[,wk] <- (yh[,wk] - .5)/ee
      ph[,wk] <- (yh[,wk] + .5)/ee
      pl[,wk][yh[,wk] == 0] <- -5
      pl[,wk][yh[,wk] == ee] <- 5
    }
  }
  
  list(pl = pl, ph = ph)
}

.setupReduct <- function(modelList, S, Q, n){
  
  REDUCT <- F
  N <- r <- rl <- NULL
  
  reductList <- modelList$reductList
  
  if( 'REDUCT' %in% names(modelList) ){
    if( !modelList$REDUCT )return(rl = NULL)
  }
  
  if( !is.null(reductList) ){
    
    N  <- floor( min( c(reductList$N, S/2) ) )
    r  <- min( c(reductList$r, .7*N) )
    rl <- list(N = N, r = ceiling(r) )
    return( rl )
  }
  
  if(n < 2*S | S > 200){
    
    N  <- round( S/3 )
    if(N > 25)N <- 25
    if(N < 4)N  <- 4
    r <- ceiling( N/2 )
    
    rl <- list(r = r, N = N, alpha.DP = S)
    warning( 'dimension reduction' )
  }
  rl
}

.getTimeIndex <- function(timeList, other, notOther, xdata, x, xl, y, w,
                          termB, termR, termA ){
  Q <- ncol(x)
  n <- nrow(x)
  xnames <- colnames(x)
  snames <- colnames(y)
  loBeta <- hiBeta <- alphaPrior <- Rmat <- Rpattern <- wL <- gindex <- 
    Vmat <- Rrows <- loRmat <- hiRmat <- Arows <- Amat <- Apattern <- wA <- 
    Umat <- uindex <- loAmat <- hiAmat <- aindex <- Brows <- bg <- Bpattern <- 
    wB <- loB <- hiB <- zB <- zA <- zR <- NULL
  
  timeZero <- timeList$timeZero
  timeLast <- timeList$timeLast
  
  if(length(timeZero) != length(timeLast))
    stop('timeZero and timeLast different lengths')
  times    <- timeList$times
  
  if(is.null(times))
    stop(' column name "times" needed for time-series model' )
  timeZero <- which(xdata[,'times'] == 0)
  if(length(timeZero) == 0)stop(' must have time zero in xdata[,time] ')
  
  timeLast <- timeZero - 1
  timeLast <- timeLast[-1]
  timeLast <- c(timeLast,nrow(xdata))
  
  w2 <- which(timeLast - timeZero < 2)
  if(length(w2) > 0)
    stop('some sequences have only 2 time intervals, need at least 3')
  
  ix <- 1:n
  t1 <- ix[-timeZero]
  t0 <- t1 - 1
  t2 <- t1 + 1
  tindex <- cbind(t0,t1,t2)
  S  <- ncol(y)
  
  ns <- length(timeZero)
  nt <- nrow(tindex)
  i1 <- i2 <- numeric(0)
  
  for(k in 1:ns){
    
    tl <- timeLast[k]
    sk <- timeZero[k]
    wk <- which(tindex[,1] >= sk & tindex[,2] <= tl)
    k1 <- wk[ seq(1, length(wk), by = 2) ] #location in tindex, by 2
    k2 <- k1 + 1
    k2 <- k2[ k2 <= nt ]
    k2 <- k2[ tindex[k2,2] <= tl ]
    i1 <- c(i1, k1)
    i2 <- c(i2, k2)
  }
  
  maxTime <- max(xdata$times)
  inSamples <- tindex[,2]
  
  if(termB){ # beta
    
    if('betaPrior' %in% names(timeList)){
      bm    <- model.frame( timeList$formulaBeta, xdata )
      int   <- attr( attributes(bm)$terms, 'intercept' )
      bnames <- attr( attributes(bm)$terms, "term.labels")
      if( int == 1 )bnames <- c( 'intercept', bnames )
      loBeta <- timeList$betaPrior$lo
      hiBeta <- timeList$betaPrior$hi
      beta   <- (loBeta + hiBeta)/2
      beta[ is.nan(beta) | beta == -Inf | beta == Inf ] <- 0
      
      bg <- matrix( 0, length(bnames), ncol(beta) )
      rownames(bg) <- bnames
      colnames(bg) <- colnames(beta)
      lo <- bg - 100
      hi <- bg + 100
      
      lo[ rownames(loBeta), ] <- loBeta
      hi[ rownames(hiBeta), ] <- hiBeta
      bg[ rownames(beta), ] <- beta
      
      loBeta <- lo
      hiBeta <- hi
      beta   <- bg
      
    } else{
      beta <- matrix(0,Q,S)
      rownames(beta) <- colnames(x)
      BPRIOR <- F
    }
    
    tmp <- .betaPrior(beta, notOther, loBeta, hiBeta)
    bg <- tmp$beta; loB <- tmp$loB;   hiB <- tmp$hiB
    wB <- tmp$wB;    zB <- tmp$zB; BPRIOR <- tmp$BPRIOR
    bg[is.nan(bg) | bg == -Inf | bg == Inf] <- 0
    
    tmp   <- .getPattern(bg[,notOther,drop=F], wB)
    Brows <- tmp$rows
    Bpattern <- tmp$pattern
    bg[!is.finite(bg)] <- 0
  }
  
  if(termA){ # alpha
    
    if( 'alphaPrior' %in% names(timeList) ){
      loAlpha <- timeList$alphaPrior$lo
      hiAlpha <- timeList$alphaPrior$hi
      loAlpha[is.na(loAlpha) | is.na(hiAlpha)] <- hiAlpha[is.na(loAlpha) | is.na(hiAlpha)] <- 0
    } else{
      alpha <- diag(NA,S)
      diag(alpha) <- -1
    }
    
    tmp <- .alphaPrior(w, tindex, ap = timeList$alphaPrior, notOther)
    Amat <- tmp$Amat; loAmat <- tmp$loAmat; hiAmat <- tmp$hiAmat
    wA   <- tmp$wA; # Umat <- tmp$Umat; umat <- tmp$umat
    uindex <- tmp$uindex; aindex <- tmp$aindex
    
    U <- nrow(Amat)
    Umat <- matrix(0,n,U)
    wz   <- w
    wz[wz < 0] <- 0
    
    Umat <- wz[,uindex[,1]]*wz[,uindex[,2]] # note: tindex[,2] makes this w[t-1,]*w[t-1,]
    
    tmp      <- .getPattern(loAmat, wA)
    Arows    <- tmp$rows
    Apattern <- uindex
  #  Apattern[ Apattern[,2] == Apattern[,1], 2] <- NA
    
    Amat[!is.finite(Amat)] <- 0
    zA <- which(Amat == 0)
    
    wrow <- max(wA[,1])
    wcol <- max(wA[,2])
    
    Apattern <- Apattern[ Apattern[,1] %in% c(1:wrow),]
    Apattern <- Apattern[ !Apattern[,1] > wcol,]
   # Apattern[Apattern %in% other] <- NA
    Apattern <- Apattern[1:wrow,]
  }
  
  if(termR){ # rho
    
    if( 'rhoPrior' %in% names(timeList) ){
      lprior <- timeList$rhoPrior
      lprior$lo[ is.na(lprior$lo) | is.na(lprior$hi) ] <- 0
      lprior$hi[ is.na(lprior$lo) | is.na(lprior$hi) ] <- 0
    } else{
      lprior <- timeList$betaPrior
    }
    xlnames <- colnames(xl)
    tmp <- .rhoPrior(lprior, w, xl, tindex, xlnames, 
                        snames, other, notOther, timeLast)
    Rmat <- tmp$Rmat; loRmat <- tmp$loRmat; hiRmat <- tmp$hiRmat
    wL <- tmp$wL; gindex <- tmp$gindex; Vmat <- tmp$Vmat
    zR <- which( is.na(Rmat) )
    
    ltmp <- matrix(NA,nrow(Rmat),length(notOther))
    ltmp[wL] <- 1
    
    tmp <- .getPattern(ltmp, wL)
    Rrows <- tmp$rows
    Rpattern <- tmp$pattern
    Rmat[!is.finite(Rmat)] <- 0
  }
  
 # tindex <- tindex[!tindex[, 2] %in% timeLast, ]
  
  list(Rmat = Rmat, Rpattern = Rpattern, wL = wL, gindex = gindex,
       Vmat = Vmat, Rrows = Rrows, loRmat = loRmat, hiRmat = hiRmat,
       Arows = Arows, Amat = Amat, Apattern = Apattern, wA = wA, 
       Umat = Umat, uindex = uindex,loAmat = loAmat, hiAmat = hiAmat,
       aindex = aindex, Brows = Brows, bg = bg, Bpattern = Bpattern, wB = wB, 
       loB = loB, hiB = hiB, zB = zB, zA = zA, zR = zR, timeZero = timeZero, 
       timeLast = timeLast, maxTime = maxTime, inSamples = inSamples, 
       tindex = tindex, i1 = i1, i2 = i2)
}

.checkYfactor <- function(ydata, typeNames){
  
  yordNames <- NULL
  
  wf <- which( sapply(ydata,is.factor) )
  
  if( length(wf) > 0 ){
    if(!all(typeNames[wf] == 'CAT'))
      stop('factors in ydata must be CAT data')
  }
  wc <- which( typeNames == 'CAT' )
  wc <- which( !wc %in% wf )
  if(length(wc) > 0){
    ydata <- data.frame(ydata)
    for(k in wc){
      ydata[,k] <- as.factor(ydata[,k])
    }
  }
    
  
  list(ydata = ydata, yordNames = yordNames)
}

.buildEffort <- function(y, effort, typeNames, verbose){
  
  S <- length(typeNames)
  
  effMat <- y*0 + 1
  effMat[is.na(effMat)] <- 1
  
  if( is.null(effort) ){
    effort <- list(columns = 1:S, values = effMat)
  } else {
    
    if( is.list(effort$values) ){
      effort$values <- as.matrix(effort$values)
    }
    if( !is.matrix(effort$values) ){
      
      if(length(effort$values) == ncol(y)){
        byrow <- T
        warning('effort$values applied to columns')
      }else{
        byrow <- F
        toConsole( 'effort$values applied to rows', verbose = verbose )
      }
      
      effMat <- matrix( effort$values, nrow(y), ncol(y), byrow = byrow)
      rownames(effMat) <- rownames(y)
      colnames(effMat) <- colnames(y)
    }
    
    effMat[,effort$columns] <- effort$values
    effort$values <- as.matrix( effMat )
    if(!is.null(colnames(effort$values)))colnames(effMat) <- .cleanNames(colnames(effMat))
  }
  effort$columns <- 1:S
  
  effMat <- as.matrix(effMat)
  
  we <- which(effort$values == 0 | is.na(effort$values))
  
  if(length(we) > 0){
    effort$values[we] <- 1
    if( any(c('DA','CC') %in% typeNames) )
      warning('missing or zero values in effort')
  }

  effMat[,!typeNames == 'DA'] <- 1
  effMat[effMat == 0] <- 1
  effort <- list(columns = effort$columns, values = effMat)
  
  effort
}

.setupFactors <- function(xdata, xnames, factorObject){
  
  factorList <- factorObject$factorList
  contrast   <- factorObject$contrast
  
  Q  <- length(xnames)
  if(Q == 1){
    return( list(dCont = matrix(1)) )
  }
  q1 <- Q - 1
  fnames <- xnames
  findex <- character(0)
  nfact  <- length(factorList)
  
  if(nfact > 0){              # exclude main effects of factors
    findex <- sort( unique( unlist(factorList) ) )
    fnames <- fnames[!fnames %in% findex]
  }
  
  tmp <- diag(length(fnames))
  rownames(tmp) <- colnames(tmp) <- fnames
  if(length(tmp) < 2){
    eCont <- frow <- intercept <- numeric(0)
  } else {
    eCont <- tmp[drop=F,-1,]
    frow  <- rep(0,nrow(eCont))
    intercept <- rep(0,nrow(eCont))
  }
  dCont <- lCont <- eCont
  
  if(nfact > 0){
    
    for(k in 1:nfact){
      
      cm <- contrast[[k]]
      colnames(cm) <- factorList[[k]]
      rownames(cm) <- paste(names(factorList)[[k]],rownames(cm),sep='')
      
      facK <- names(factorList)[[k]]
      
      wx <- match(facK,colnames(xdata))
      
      fnames <- as.character( levels(xdata[[wx]]) ) 
      mm     <- .getContrasts(facK, fnames)
      D  <- mm$D                      # for Z <- x%*%D; 
      L  <- mm$L                      # for A <- L%*%bg; 
      C  <- mm$C                      # L <- solve(t(C)); C = solve(t(L))
      
      if( length(eCont) > 1 ){
        eCont <- .blockDiag(eCont,cm)
        dCont <- .blockDiag(dCont,D[,-1,drop=F])
        lCont <- .blockDiag(lCont,L[,-1,drop=F])
        ec    <- nrow(lCont)
        bc    <- ec - nrow(L) + 1
        lCont[bc:ec,1] <- L[,1]
        dCont[bc,1] <- -1
      } else {
        eCont <- cbind(0,cm)
        colnames(eCont)[1] <- 'intercept'
        dCont <- D
        lCont <- L
      }
      nr2   <- nrow(cm)
      nc2   <- ncol(cm)
      intercept <- c(intercept,rep(1,nr2))
      
      frow <- c(frow,rep(k,nr2))
    }
    eCont[,1] <- intercept
  }
  
  eCont <- eCont[drop=F,,xnames]
  
  dCont <- t(dCont[drop=F,,xnames])
  dCont[1,] <- abs(dCont[1,])
  lCont <- lCont[drop=F,,xnames]
  
  q1 <- nrow(eCont)                # level names only
  fnames   <- rownames(eCont)
  facList2 <- factorList
  if(nfact > 0){
    for(j in 1:nfact){
      wj <- which(names(xdata) == names(factorList)[j])
      facList2[[j]] <- levels(xdata[[wj]])
    }
  }
  
  fmat <- matrix(0,q1,q1)
  colnames(fmat) <- rownames(fmat) <- fnames
  
  findex <- match(findex,xnames)
  
  list(factorList = factorList, facList2 = facList2, fmat = fmat, fnames = fnames,
       q1 = q1, lCont = lCont, dCont = dCont, eCont = eCont, findex = findex)
}

gjamSensitivity <- function(output, group=NULL, nsim=100, PERSPECIES = TRUE){
  
  # PERSPECIES - sensitivity on per-species basis, otherwise depends on no. of species
  
  REDUCT <- FALSE
  
  standRows   <- output$inputs$standRows
  factorBeta  <- output$inputs$factorBeta
  notOther    <- output$inputs$notOther
  standMatSd  <- output$inputs$standMatSd
  notStandard <- output$modelList$notStandard
  ng          <- output$modelList$ng
  burnin      <- output$modelList$burnin
  x           <- output$inputs$xStand
  y           <- output$inputs$y
  beta        <- output$parameters$betaMu
  snames      <- colnames(y)
  xnames      <- colnames(x)
  Q  <- length(xnames)
  S  <-  length(snames)
  S1 <- length(notOther)
  
  bgibbs    <- output$chains$bgibbs
  sgibbs    <- output$chains$sgibbs
  if('kgibbs' %in% names(output$chains)){
    REDUCT <- T
    kgibbs      <- output$chains$kgibbs   
    sigErrGibbs <- output$chains$sigErrGibbs
    N <- output$modelList$reductList$N
    r <- output$modelList$reductList$r
  }
  
  jj <- sample(burnin:ng,nsim,replace=T)
  i  <- 1
  
  ns <- S
  if( !is.null(group) )ns <- length(group)
  
  for(j in jj){
    
    bg <-  matrix(bgibbs[j,],Q,S)
    rownames(bg) <- xnames
    colnames(bg) <- snames
    
    if(!REDUCT){
      sg <- .expandSigma(sgibbs[j,], S = S, REDUCT = F) 
      si <- solveRcpp( sg ) 
      
    } else {
      Z  <- matrix(sgibbs[j,],N,r)
      sg <- .expandSigma(sigErrGibbs[j], S, Z = Z, kgibbs[j,], REDUCT = T)
      si <- invWbyRcpp(sigErrGibbs[j], Z[kgibbs[j,],])
    }

    tmp <- .contrastCoeff(beta=bg[,notOther], 
                          notStand = notStandard[notStandard %in% xnames], 
                          sigma = sg[notOther,notOther],
                          sinv = si[notOther,notOther],
                          stand = standMatSd, factorObject=factorBeta,
                          conditional = group)
    if(i == 1){
      fmat <- matrix(0,nsim,ncol(tmp$sens))
    }
    
    fsens <- diag(tmp$sens)
    if(PERSPECIES)fsens <- fsens/ns
    
    fmat[i,] <- fsens
    i <- i + 1
  }
  colnames(fmat) <- colnames(tmp$sens)
  fmat
}

.factorCoeffs2Zero <- function(factorObject, snames, priorObject){
  
  # missing factor levels
  
  zero  <- numeric(0)
  
  for(k in 1:factorObject$nfact){
    
    wk <- grep('_',factorObject$missFacSpec[[k]])
    
    if(length(wk) > 0){
      sx <- .splitNames(factorObject$missFacSpec[[k]])$vnam
      ij <- cbind(match(sx[,2],rownames(priorObject$lo)),match(sx[,1],snames))
      zero <- rbind(zero,ij)
    }
  }
  zero
}

.cleanDims <- function(mat){
  colnames(mat) <- .cleanNames( colnames(mat) )
  rownames(mat) <- .cleanNames( rownames(mat) )
  mat
}

.cleanTimePriors <- function(form, prior, xdata){
  
  # prior is a list with matrix 'lo' and 'hi'
  formTerms <- unlist( strsplit( as.character(form), '+', fixed=T) )
  formTerms <- .replaceString( formTerms[ !formTerms == '~' ], ' ', '')
  
  xn <- colnames( model.matrix(form, xdata) )
  xn[1] <- 'intercept'
  
  rownames(prior$lo) <- .cleanNames(rownames(prior$lo))
  rownames(prior$hi) <- .cleanNames(rownames(prior$hi))
  
  plo <- matrix(-Inf, length(xn), ncol(prior$lo))
  rownames(plo) <- xn
  colnames(plo) <- colnames(prior$lo)
  phi <- -plo
  
  prior$lo <- prior$lo[ drop=F, rownames(prior$lo) %in% rownames(plo),]
  prior$hi <- prior$hi[ drop=F, rownames(prior$hi) %in% rownames(phi),]
  
  
  plo[rownames(prior$lo),] <- prior$lo
  phi[rownames(prior$hi),] <- prior$hi
  
  attr(prior$lo, "formula") <- form
  attr(prior$hi, "formula") <- form
  
  prior$lo <- .cleanDims(prior$lo)
  prior$hi <- .cleanDims(prior$hi)
  
  list( prior = prior, formTerms = formTerms, xnames = xn)
}

.gjam <- function(formula, xdata, ydata, modelList, verbose = FALSE){
  
  holdoutN      <-  0
  holdoutIndex  <- numeric(0)
  breakList <- modelSummary <- reductList  <- traitList <- NULL
  specByTrait <- traitTypes <- notStandard <- NULL
  censor <- censorCA <- censorDA <- CCgroups <- FCgroups <- intMat <- NULL
  N  <- r <- otherpar <- pg <- NULL
  bFacGibbs <- fSensGibbs <- sensTable <- NULL
  facNames  <- character(0)
  groupRandEff <- NULL
  x <- y <- y0 <- effort <- NULL
  xnames <- xlnames <- NULL
  ng     <- 2000
  burnin <- 500
  BPRIOR <- LPRIOR <- REDUCT <- TRAITS <- FULL <- FALSE
  termB <- termR <- termA <- FALSE
  PREDICTX <- TRUE
  rhoPrior <- betaPrior <- alphaPrior <- NULL
  
  RANDOM <- FALSE              # random group intercepts
  
  TIME <- FALSE
  timeList <- timeZero <- timeLast <- timeIndex <- groupIndex <- 
    rowInserts <- Rmat <- Amat <- beta <- NULL
  formulaBeta <- NULL
  xl <- NULL
  
  ematAlpha <- .5

  alpha.DP <- ncol( ydata )          # large values give more variation
  
  xdata <- as.data.frame( xdata )
  
  colnames(ydata) <- .cleanNames( colnames(ydata) )
  colnames(xdata) <- .cleanNames( colnames(xdata) )
  
  wf <- which(sapply(xdata, is.factor))
  if(length(wf) > 0){
    for(j in wf){
      jt <- as.character(xdata[,j])
      jt <- .cleanNames( jt )
      xdata[,j] <- as.factor(jt)
    }
  }
  
  if(alpha.DP == 1)
    stop('this is a multivariate model: at least 2 columns needed in ydata')
  
  for(k in 1:length(modelList))assign( names(modelList)[k], modelList[[k]] )
  
  if('CCgroups' %in% names(modelList))attr(typeNames,'CCgroups')   <- CCgroups
  if('FCgroups' %in% names(modelList))attr(typeNames,'FCgroups')   <- FCgroups
  if('CATgroups' %in% names(modelList))attr(typeNames,'CATgroups') <- CATgroups
  
  if(missing(xdata)) xdata <- environment(formula)
  
  formTerms <- unlist( strsplit( as.character(formula), '+', fixed=T) )
  formTerms <- .replaceString( formTerms[ !formTerms == '~' ], ' ', '')
  
  ft <- c( grep('_', formTerms), grep('-', formTerms) )
  if(length(ft) > 0)stop( " reserved characters '_' or '-' in formula variables, rename" )
  
  if( is.null(timeList) ){
    
    termB <- TRUE
    if( !is.null(betaPrior) ) BPRIOR <- TRUE
    
  }else{
    
    toConsole( 'Note: Fitted as a time series model', verbose = verbose )
    
    formTerms <- wterms <- character(0)
    
    ww <- which( sapply( timeList, is.null ) )
    if(length(ww) > 0)timeList <- timeList[ -ww ]
    
    for(k in 1:length(timeList))assign( names(timeList)[k], timeList[[k]] )
    
    if( "betaPrior" %in% names(timeList) ){
      
      tb <- .cleanTimePriors(formulaBeta, timeList$betaPrior, xdata)
      timeList$betaPrior <- tb$prior
      formTerms <- tb$formTerms
      xnames    <- tb$xnames
      
      wterms <- 'beta'
      termB  <- TRUE
      
      if( all(timeList$betaPrior$lo == -Inf) &
          all(timeList$betaPrior$hi == Inf) ){
        betaPrior <- NULL
        BPRIOR    <- FALSE
      }else{
        BPRIOR <- TRUE
      }
    }
    
    if( "rhoPrior" %in% names(timeList) ){
      
      formulaRho <- timeList$formulaRho
      
      tb <- .cleanTimePriors(formulaRho, timeList$rhoPrior, xdata)
      timeList$rhoPrior <- tb$prior
      formTerms <- unique( c(formTerms, tb$formTerms) )
      xlnames   <- tb$xnames
      wterms    <- c( wterms, 'rho')
      
      termR  <- TRUE
      LPRIOR <- TRUE
    }
    
    if( "alphaPrior" %in% names(timeList) ){
      timeList$alphaPrior$lo <- .cleanDims(timeList$alphaPrior$lo)
      timeList$alphaPrior$hi <- .cleanDims(timeList$alphaPrior$hi)
      wterms <- c( wterms, 'alpha')
      termA  <- TRUE
      APRIOR <- TRUE
    }
    
    toConsole( 'Note: Time series terms', wterms, verbose = verbose )
    
    if( length(formTerms) > 1 & '1' %in% formTerms )
      formTerms <- formTerms[ formTerms != '1' ]
    formTerms <- paste( '~', paste0(formTerms, collapse = '+') )
    formula   <- as.formula( formTerms  )
    
    TIME     <- T
    holdoutN <-  0
    holdoutIndex  <- numeric(0)
  }
  
  if( is.character(formula) )formula <- as.formula(formula)
  
  if( !is.null(traitList) ){
    TRAITS <- T
    for(k in 1:length(traitList))assign( names(traitList)[k], traitList[[k]] )
    
    stt <- .replaceString(colnames(specByTrait),'_','')
    colnames(specByTrait) <- stt
    colnames(plotByTrait) <- stt
    colnames(traitList$specByTrait) <- stt
    colnames(traitList$plotByTrait) <- stt
    modelList$traitList <- traitList
    
    toConsole( 'Fitted as a trait model', verbose = verbose )
  }
  
  if(burnin >= ng) stop( 'burnin must be < no. MCMC steps, ng' )
  
  if('censor' %in% names(modelList)){
    for(k in 1:length(censor)){
      if( nrow(censor[[k]]$partition) != 3 )
        stop('censor matrix: 3 rows for value, lo, hi')
      rownames(censor[[k]]$partition) <- c('value','lo','hi')
    }
  }
  
  S <- ncol(ydata)
  if(length(typeNames) == 1)typeNames <- rep(typeNames,S)
  if(length(typeNames) != S) 
    stop('typeNames must be one value or no. columns in y')
  
  ############### factors in y
  
  tmp   <- .checkYfactor(ydata, typeNames)
  ydata <- tmp$ydata; yordNames <- tmp$yordNames
  
  if(TRAITS){
    if(!all( typeNames %in% c('CC','FC') ) )
      stop('trait prediction requires composition data (CC or FC)')
    if(nrow(plotByTrait) != nrow(ydata))
      stop('nrow(plotByTrait) must equal nrow(ydata)')
    if(ncol(plotByTrait) != length(traitTypes))
      stop('ncol(plotByTrait) must equal length(traitTypes)')
    if(ncol(plotByTrait) != length(traitTypes))
      stop('ncol(plotByTrait) must equal length(traitTypes)')
    ii <- identical(rownames(specByTrait),colnames(ydata))
    if(!ii){
      ww <- match(colnames(ydata),rownames(specByTrait) )
      if( is.finite(min(ww)) ){
        specByTrait <- specByTrait[ww,]
      } else {
        stop( 'rownames(specByTrait) must match colnames(ydata)' )
      }
    }
    if(typeNames[1] == 'CC'){
      ytmp <- round(ydata,0)
      ytmp[ytmp == 0 & ydata > 0] <- 1
      ydata <- ytmp
      rm(ytmp)
    }
  }
  
  tmp <- .buildYdata(ydata, typeNames)
  y   <- as.matrix( tmp$y )
  ydataNames <- tmp$ydataNames
  typeNames  <- tmp$typeNames
  CCgroups   <- tmp$CCgroups
  FCgroups   <- tmp$FCgroups
  CATgroups  <- tmp$CATgroups
  if(TRAITS) rownames(specByTrait) <- colnames(y)
  
  S <- ncol(y)
  n <- nrow(y)
  
  
  toConsole( 'Observations and responses', c(n, S), verbose = verbose )
  
  tmp    <- .buildEffort(y, effort, typeNames, verbose)
  effort <- tmp
  effMat <- effort$values
  modelList$effort <- effort
  
  w <- y/effMat
  
# efactor <- 1
# efactor <- round( apply( w, 2, mean ) )
# if( termA ) efactor[ 1:length(efactor) ] <- round( mean(efactor) )
 
# if( mean(efactor) > 100 ){
#   effMat <- t(t(effMat)*efactor)
#   effort$values <- effMat
#   w <- y/effMat
# }
  
  tmp      <- .gjamGetTypes(typeNames)
  typeCols <- tmp$typeCols
  typeFull <- tmp$typeFull
  typeCode <- tmp$TYPES[typeCols]
  allTypes <- sort(unique(typeCols))
  
#  if( UNSTAND )notStandard <- colnames(xdata)
#  standard <- colnames(xdata)[!colnames(xdata) %in% notStandard]
#  standard <- standard[ standard != 'intercept' ]
  
  tmp <- .gjamXY(formula, xdata, y, typeNames, notStandard, verbose = verbose) # all terms
  x      <- tmp$x; y <- tmp$y; snames <- tmp$snames
  xnames <- tmp$xnames
  interBeta   <- tmp$interaction 
  factorBeta  <- tmp$factorAll
  designTable <- tmp$designTable
  xscale      <- tmp$xscale
  predXcols   <- tmp$predXcols
  standMatSd  <- tmp$standMatSd
  standMatMu  <- tmp$standMatMu  
  xdataNames  <- tmp$xdataNames
  standRows   <- tmp$standRows
  
  factorRho <- interRho <- NULL
  xlnames   <- character(0)
  
  if( termB & TIME ){
    
    tmp    <- .gjamXY(formulaBeta, xdata, y, typeNames, notStandard)
    xnames <- tmp$xnames
    interBeta    <- tmp$interaction
    factorBeta   <- tmp$factorAll
    designTable  <- list(beta = tmp$designTable)
    standMatSdB  <- tmp$standMatSd
    standMatMuB  <- tmp$standMatMu
    standRowsB   <- tmp$standRows 
    notStandardB <- tmp$notStandard
  }
  
  if( termR ){
    
    tmp <- .gjamXY(formulaRho, xdata, y, typeNames, notStandard)
    xl  <- tmp$x
    xlnames      <- tmp$xnames
    interRho     <- tmp$interaction
    factorRho    <- tmp$factorAll
    designTable  <- append( designTable, list(rho = tmp$designTable) )
    standMatSdL  <- tmp$standMatSd
    standMatMuL  <- tmp$standMatMu
    standRowsL   <- tmp$standRows
    notStandardL <- tmp$notStandard[tmp$notStandard %in% xlnames]
    
    rho <- matrix(0, ncol(xl), ncol(y))
    rownames(rho) <- colnames(xl)
    colnames(rho) <- colnames(y)
  }

  modelList$formula      <- formula
  modelList$notStandard  <- notStandard
  
  Q <- ncol(x)
  
  tmp <- .gjamMissingValues(x, y, factorBeta$factorList, typeNames, verbose)
  xmiss  <- tmp$xmiss;   xbound <- tmp$xbound; 
  ymiss  <- tmp$ymiss;   missY <- tmp$missY
  xprior <- tmp$xprior;  yprior <- tmp$yprior
  nmiss  <- nrow(xmiss); mmiss  <- nrow(ymiss)
  x  <- tmp$x; y <- tmp$y
           
  if( termR ){
    tmp <- .gjamMissingValues(xl, y, factorRho$factorList, typeNames)
    xlmiss  <- tmp$xmiss;   xlbound <- tmp$xbound; 
    xlprior <- tmp$xprior
    nlmiss  <- nrow(xmiss)
    xl <- tmp$x
  }
  
  tmp <- .gjamHoldoutSetup(holdoutIndex, holdoutN, n)
  holdoutIndex <- tmp$holdoutIndex; holdoutN <- tmp$holdoutN
  inSamples    <- tmp$inSamples;         nIn <- tmp$nIn
  
  tmp <- .gjamSetup(typeNames, x, y, breakList, holdoutN, holdoutIndex,
                    censor=censor, effort=effort) 
  w <- tmp$w; z <- tmp$z; y <- tmp$y; other <- tmp$other; cuts <- tmp$cuts
  cutLo       <- tmp$cutLo; cutHi <- tmp$cutHi; plo <- tmp$plo; phi <- tmp$phi
  ordCols     <- tmp$ordCols; disCols <- tmp$disCols; compCols <- tmp$compCols 
  conCols     <- which(typeNames == 'CON')
  classBySpec <- tmp$classBySpec; breakMat <- tmp$breakMat
  minOrd      <- tmp$minOrd; maxOrd <- tmp$maxOrd; censorCA <- tmp$censorCA
  censorDA    <- tmp$censorDA; censorCON <- tmp$censorCON; 
  ncut <- ncol(cuts);  corCols <- tmp$corCols
  catCols     <- which(attr(typeNames,'CATgroups') > 0)
  sampleW     <- tmp$sampleW
  ordShift    <- tmp$ordShift
  
  sampleW[censorCA] <- 1
  sampleW[censorDA] <- 1
  sampleW[censorCON] <- 1
  sampleWhold <- tgHold <- NULL
  wHold <- NULL
  wmax  <- 1.5*apply(y/effMat,2,max,na.rm=T)
  pmin  <- -abs(wmax)
  
  if(mmiss > 0){
    phi[ ymiss ] <- wmax[ ymiss[,2] ]
    plo[ ymiss ] <- pmin[ ymiss[,2] ]
    sampleW[ ymiss ] <- 1
  }
  
  ploHold <- phiHold <- NULL
  
  if( holdoutN > 0 ){
    
    sampleWhold <- sampleW[holdoutIndex,]  #to predict X
    sampleW[holdoutIndex,] <- 1
    tgHold  <- cuts
    wHold   <- w[drop=F,holdoutIndex,]
    ploHold <- plo[drop=F,holdoutIndex,]   # if LOHI: updated to current yp
    phiHold <- phi[drop=F,holdoutIndex,]
  }

  byCol <- byRow <- F
  if(attr(sampleW,'type') == 'cols')byCol <- T
  if(attr(sampleW,'type') == 'rows')byRow <- T
  indexW <- attr(sampleW,'index')
  
  notCorCols <- c(1:S)
  if(length(corCols) > 0)notCorCols <- notCorCols[-corCols]
  
  ############ 'other' columns
  Q  <- ncol(x)
  sigmaDf  <- nIn - Q + S - 1   
  sg <- diag(.1,S)
  SO <- S
  
  notOther <- c(1:S)
  sgOther  <- NULL
  if(length(other) > 0){                     
    notOther    <- notOther[!notOther %in% other]
    SO          <- length(notOther)
    sg[other,]  <- sg[,other] <- 0
    sgOther     <- matrix( cbind(other,other),ncol=2 )
    sg[sgOther] <- .1
  }
  if(length(corCols) > 0){
    sg[corCols,corCols] <- 1
  }
  
  ############## prior on beta
  loB <- hiB <- NULL
  beta <- bg <- matrix(0, Q, S)
  rownames(beta) <- colnames(x)
  
  wB <- which(bg == 0, arr.ind=T)
  
  if( BPRIOR ){
    
    loB <- betaPrior$lo
    hiB <- betaPrior$hi
    
    if( ncol(loB) != ncol(y) |
        ncol(hiB) != ncol(y))stop('betaPrior$lo or betaPrior$hi do not match ydata columns')
    
    xrange <- max( abs(range(x)) )              # for intercept
    loB['intercept', loB['intercept',] < -10*xrange] <- -10*xrange
    hiB['intercept', hiB['intercept',] > 10*xrange]  <- 10*xrange
    
    if(length(standRows) > 0){
      sr   <- names(standRows)[ names(standRows) %in% rownames(loB) ]
      btmp <- loB[sr,]
      btmp[ which(btmp < -5) ] <- -5  # standard deviations, x is standardized
      loB[sr, ] <- btmp
      
      sr   <- names(standRows)[ names(standRows) %in% rownames(hiB) ]
      btmp <- hiB[sr,]
      btmp[ btmp > 5 ] <- 5  
      hiB[sr, ] <- btmp
    }
    
    bg <- (loB + hiB)/2
    bg[is.nan(bg)] <- 0
    
    tmp <- .betaPrior(bg, notOther, loB, hiB)
    bg <- tmp$beta; loB <- tmp$loB; hiB <- tmp$hiB
    wB <- tmp$wB;    zB <- tmp$zB
    bg[is.nan(bg) | bg == Inf | bg == -Inf] <- 0
    
    tmp <- .getPattern(bg[,notOther, drop=F], wB)
    Brows <- tmp$rows
    Bpattern <- tmp$pattern
    bg[!is.finite(bg)] <- 0
    zeroBeta <- .factorCoeffs2Zero(factorBeta, snames, betaPrior)  # max zero is missing factor level
  }
  
  zeroRho <- uindex <- NULL
  
  ############### time 
  if( TIME ){
    
    if( !all(typeNames == 'DA') )stop( "gjamTime only implemented for DA (count) data" )
    
    wB <- wL <- wA <- numeric(0)
    mua  <- mub <- mug <- muw <- w*0
    Umat <- Vmat <- Rmat <- Amat <- NULL
    Brows <- Rrows <- Arows <- Bpattern <- Rpattern <- Apattern <- NULL
    
    tmp <- .getTimeIndex(timeList, other, notOther, xdata, x, xl, y, w,
                         termB, termR, termA)
    if(termA){
      Amat   <- tmp$Amat; Apattern <- tmp$Apattern; wA <- tmp$wA; zA = tmp$zA;
      Umat   <- tmp$Umat;   uindex <- tmp$uindex; Arows <- tmp$Arows
      loAmat <- tmp$loAmat; hiAmat <- tmp$hiAmat; aindex <- tmp$aindex
      Unew <- Umat
      if( !is.finite(mean(loAmat[wA])) )stop( 'values in loAmat not finite: check .getTimeIndex' )
    }
    if( termR & LPRIOR ){
      Rmat   <- tmp$Rmat; Rpattern <- tmp$Rpattern;  wL <- tmp$wL; zR = tmp$zR;      
      Vmat   <- tmp$Vmat;    Rrows <- tmp$Rrows;  gindex <- tmp$gindex
      loRmat <- tmp$loRmat; hiRmat <- tmp$hiRmat
      zeroRho <- .factorCoeffs2Zero(factorRho, snames, rhoPrior)
      timeList$rhoPrior$hi[zeroRho] <- rhoPrior$hi[zeroRho] <- 0
      Vnew <- Vmat
      
      standMatSdRmat <- Rmat*0
      notStandardRmat <- numeric(0)
      
      if(length(standRowsL) > 0){
        csl <- paste('_',names(standRowsL),sep='')
        for(j in 1:length(csl)){
          wj <- grep(csl[j],rownames(Rmat))
          standMatSdRmat[wj,] <- standMatSdL[standRowsL[j],]
          notStandardRmat <- c(notStandardRmat,wj)
        }
      }
    }
    if(termB){
      Brows  <- tmp$Brows; bg <- tmp$bg; Bpattern <- tmp$Bpattern
      wB     <- tmp$wB; zB <- tmp$zB; loB <- tmp$loB; hiB <- tmp$hiB
      if(BPRIOR)timeList$betaPrior$hi[zeroBeta] <- betaPrior$hi[zeroBeta] <- 0     
    }
    
    timeZero <- tmp$timeZero; timeLast <- tmp$timeLast
    maxTime  <- tmp$maxTime; inSamples <- tmp$inSamples 
    tindex   <- tmp$tindex; sindex <- tmp$sindex; i1 <- tmp$i1; i2 <- tmp$i2
    
    if(!REDUCT ){
      if(length(wA) > 300)modelList$reductList <-  list(N = 8, r = 5)
    }
    
    bigx <- numeric(0)
    if(termB){
      bigx <- x[drop=F, tindex[,2], xnames]
      nb <- nrow(bg)
    }
    if(termR){
      bigx <- cbind(bigx, Vmat[tindex[,2],])
      nr <- nrow(Rmat)
    }
    if(termA){
      bigx <- cbind(bigx, Umat[tindex[,2],])
      na <- nrow(Amat)
    }
    
    bigc <- crossprod(bigx)
    diag(bigc) <- diag(bigc)*1.00001
    bigi <- try( solveRcpp(bigc), silent = TRUE )
    
    if(inherits(bigi,'try-error'))bigi <- ginv(bigc)
    
    Y <- w[tindex[,2],notOther] - w[tindex[,1],notOther]
    init <- bigi%*%crossprod(bigx, Y)
    
    if( termB ){
      binit <- init[1:nb,]
      init  <- init[-c(1:nb),]
      binit[binit < loB] <- loB[binit < loB]
      binit[binit > hiB] <- hiB[binit > hiB]
      
      ones <- binit*0 
      ones[ wB ] <- 1
      bg[ 1:length(bg) ] <- as.vector( binit*ones )
    }
    if(termR){
      rinit <- init[1:nr,]
      init  <- init[-c(1:nr),]
      loR   <- loRmat
      hiR   <- hiRmat
      loR[ !is.finite(loR) ] <- 0
      hiR[ !is.finite(hiR) ] <- 0
      
      rinit[rinit < loR] <- ( loR[rinit < loR] + hiR[rinit < loR] )/2
      rinit[rinit > hiR] <- ( loR[rinit > hiR] + hiR[rinit > hiR] )/2
      
      ones <- rinit*0 
      ones[ wL ] <- 1
      Rmat[1:length(Rmat)] <- as.vector( rinit*ones )
      colnames(Rmat) <- snames
    }
    if(termA){
      ainit <- init
      loA   <- loAmat
      loA[ !is.finite(loA) ] <- 0
      hiA <- hiAmat
      hiA[ !is.finite(hiA) ] <- 0
      
      
      ainit[ainit < loA] <- (loA[ainit < loA] + hiA[ainit < loA])/2
      ainit[ainit > hiA] <- (loA[ainit > hiA] + hiA[ainit > hiA])/2
      
      ones <- ainit*0 
      ones[ wA ] <- 1
      Amat[1:length(Amat)] <- as.vector( ainit*ones )
      colnames(Amat) <- snames
    }

    rm(bigx, bigc, bigi, init)
  } 
  
  reductList <- .setupReduct(modelList, S, Q, n) 
  
  if( is.null(reductList) ){
    REDUCT <- FALSE
  }else{
    N <- reductList$N; r <- reductList$r
    REDUCT <- T
  }
 # if( TIME )REDUCT <- FALSE
  
  if(byCol){
    inw <- intersect( colnames(y)[indexW], colnames(y)[notOther] )
    indexW <- match(inw,colnames(y)[notOther])
  }
  
  updateBeta <- .betaWrapper(REDUCT, TIME, notOther, betaLim=max(wmax)/2)
  
  ############ dimension reduction
  
  inSamp <- inSamples
    
  .param.fn <- .paramWrapper(REDUCT, inSamp, SS=length(notOther))
  sigmaerror <- .1
  otherpar   <- list(S = S, Q = Q, sigmaerror = sigmaerror, 
                     Z = NA, K =rep(1,S), sigmaDf = sigmaDf)
  sigErrGibbs <- rndEff <- NULL
  
  yp <- y
  wmax <- ymax <- apply(y,2,max)
  wmax <- wmax/effMat
  
  if(REDUCT){
    cat( paste('\nNote: Dimension reduced from',S,'X',S,'to',N,'X',r,'in Sigma\n') )
    otherpar$N <- N; otherpar$r <- r; otherpar$sigmaerror <- 0.1
    
    otherpar$Z <- rmvnormRcpp(N, rep(0,r), 1/S*diag(r))
    otherpar$D <- .riwish(df = (2 + r + N), 
                          S = (crossprod(otherpar$Z) +
                                 2*2*diag(rgamma(r,shape=1,rate=0.001))))
    otherpar$K <- sample(1:N,length(notOther),replace=T)

    otherpar$alpha.DP <- alpha.DP
    otherpar$pvec     <- .sampleP(N=N, avec=rep(alpha.DP/N,(N-1)),
                                   bvec=((N-1):1)*alpha.DP/N, K=otherpar$K)
    kgibbs <- matrix(1,ng,S)
    sgibbs <- matrix(0,ng, N*r)
    nnames <- paste('N',1:N,sep='-')
    rnames <- paste('r',1:r,sep='-')
    colnames(sgibbs) <- .multivarChainNames(nnames,rnames)
    sigErrGibbs <- rep(0,ng)   
    
    rndEff <- w*0
    
  } else {
    Kindex <- which(as.vector(lower.tri(diag(S),diag=T)))
    nK     <- length(Kindex)
    sgibbs <- matrix(0,ng,nK)
    colnames(sgibbs) <- .multivarChainNames(snames,snames)[Kindex] # half matrix
    
    rndEff <- 0
  }
  
  out <- .param.fn( x[,xnames,drop=F], beta = bg[,notOther,drop=F], 
                    Y = w[,notOther], otherpar )  
  sg[notOther,notOther]    <- out$sg
  sinv <- solveRcpp(sg[notOther,notOther])
  otherpar      <- out$otherpar
  
  muw <- w
  
  if( !TIME ){
    
    Y   <- w[inSamp,notOther]
    sig <- sg[notOther,notOther]
    
    if(REDUCT){
      Y   <- Y - rndEff[inSamp,notOther]
      sig <- sigmaerror
    }
    
    bg[,notOther] <- updateBeta(X = x[inSamp,], Y, sig, 
                                beta = bg[,notOther], BPRIOR, loB, hiB)
    muw <- x%*%bg
    sg[other,] <- sg[,other] <- 0
    diag(sg)[other]          <- .1
    
  }else{
    
    mub <- mua <- mug <- 0
    
    xr <- rndEff
    if(termR){
      mug <- Vmat%*%Rmat
      xr  <- xr + mug
    }
    if(termA){
      mua <- Umat%*%Amat
      xr  <- xr + mua
    }
    
    Y <- w
    Y[tindex[,1],] <- Y[tindex[,2],] - w[tindex[,1],] - xr[tindex[,1],]
    ss <- crossprod(Y)/n 
    sg[notOther,notOther] <- .cov2Cor(ss + diag(diag(ss)/2) )
    
    if( REDUCT ){
      sig <- sigmaerror
    }else{ 
      sig <- sg[notOther,notOther] 
    }
    if( termB ){
      
      bg[,notOther] <- updateBeta(X = x[drop=F,tindex[,1],xnames], Y = Y[tindex[,1],notOther], 
                                  sig = sig, beta = bg[,notOther], 
                                  PRIOR = BPRIOR,
                                  lo = loB[,notOther], hi = hiB[,notOther], 
                                  rows=Brows, pattern=Bpattern, sinv = sinv, wF = wB)
      mub <- x[,xnames]%*%bg
    }
    colnames(bg) <- snames
    muw <- mub + mug + mua 
    wpropTime <- .001 + .1*abs(w)
  }
  
  rownames(sg) <- colnames(sg) <- snames
  rownames(bg) <- xnames
  
  ############ ordinal data
  
  cutg <- tg <- numeric(0)
  
  if('OC' %in% typeCode){
    
    tg       <- cutg <- cuts
    cnames   <- paste('C',1:ncut,sep='-')
    nor      <- length(ordCols)
    cgibbs   <- matrix(0,ng,(ncut-3)*nor)
    colnames(cgibbs) <- as.vector( outer(snames[ordCols],
                                         cnames[-c(1,2,ncut)],paste,sep='_') )
    tmp   <- .gjamGetCuts(y+1,ordCols)
    cutLo <- tmp$cutLo
    cutHi <- tmp$cutHi
    plo[,ordCols] <- tg[cutLo]                                        
    phi[,ordCols] <- tg[cutHi]
    lastOrd <- ncol(tg)
  }
  
  ############ setup w
  tmp <- .gjamGetTypes(typeNames)
  typeFull <- tmp$typeFull
  typeCols <- tmp$typeCols
  allTypes <- unique(typeCols)
  Y <- w
  
  LOHI <- F
  if(!LOHI & holdoutN > 0){
    minlo <- apply(plo,2,min)
    minlo[minlo > 0] <- 0
    maxhi <- apply(phi,2,max)
  }
  
  if( 'random' %in% names(modelList)) RANDOM <- TRUE
  
  if(!TIME){
    
    .updateW <- .wWrapper(REDUCT, RANDOM, S, effMat, corCols, notCorCols, typeNames, 
                          typeFull, typeCols, 
                          allTypes, holdoutN, holdoutIndex, censor, 
                          censorCA, censorDA, censorCON, notOther, sampleW, 
                          byRow, byCol,
                          indexW, ploHold, phiHold, sampleWhold, inSamp)
  }else{
    
    .updateW <- .wWrapperTime(sampleW, y, timeZero, timeLast, i1, i2, tindex, gindex,
                              uindex, notOther, n, S, REDUCT, RANDOM, TIME,
                              termB, termR, termA, corCols)
    Y <- w #other needed in .xpredSetup
    Y[ tindex[,1],] <- Y[ tindex[,2],] - w[ tindex[,1],]
    
    if(termA) Y <- Y - mua
    if(termR) Y <- Y -  mug
    if(RANDOM)Y <- Y - rndEff
  }
  
  ycount <- rowSums(y)
  if('CC' %in% typeCode)ycount <- rowSums(y[,compCols])
  
  ############ X prediction
  
  bgg <- bg
  if( TIME & termR){
    tmp <- colnames( model.matrix(formula, xdata) )
    bgg <- matrix( 0, length(tmp), S)
    rownames(bgg) <- tmp
    colnames(bgg) <- snames
    rownames(bgg)[1] <- 'intercept'
  }
  
  tmp <- .xpredSetup(Y, x, bgg, isNonLinX = interBeta$isNonLinX, 
                     factorObject = factorBeta, 
                     intMat = factorBeta$intMat, 
                     standMatSd = standMatSd, standMatMu = standMatMu, 
                     notOther, notStandard ) 
  factorBeta$linFactor <- tmp$linFactor; xpred <- tmp$xpred; px <- tmp$px
  lox <- tmp$lox; hix <- tmp$hix
  propx <- tmp$propx
  
  priorXIV  <- diag(1e-5,ncol(x))
  priorX    <- colMeans(x)
  priorX[abs(priorX) < 1e-10] <- 0
  
  linFactor <- NULL
  
  ################## random groups
  
   if( RANDOM ){
     
    rname  <- modelList$random
    randGroupTab <- table( as.character(xdata[,rname]) )
    
    wss <- names(randGroupTab[randGroupTab <= 2])
    if(length(wss) > 0){
      toConsole( 'Note: one or more random groups with one observations', verbose = verbose )
    }
    
    randGroups <- names( randGroupTab )
    G <- length(randGroups)
    
    groupIndex  <- match(as.character(xdata[,rname]),randGroups)
    rmm <- matrix(groupIndex,length(groupIndex), S)
    smm <- matrix(1:S, length(groupIndex), S, byrow=T)
    
    randGroupIndex <- cbind( as.vector(smm), as.vector(rmm) )
    colnames(randGroupIndex) <- c('species','group')
    xdata[,rname] <- as.factor(xdata[,rname])
    alphaRandGroup <- matrix(0, S, G)
    rownames(alphaRandGroup) <- snames
    colnames(alphaRandGroup) <- randGroups
    Cmat <- var(w[,notOther]/2)
    Cmat <- Cmat + diag(.1*diag(Cmat))
    Cprior <- Cmat
    CImat <- solveRcpp(Cprior)
    Ckeep <- diag(S)
    
    alphaRanSums <- alphaRanSums2 <- alphaRandGroup*0
    groupRandEff <- w*0
    
    Aindex <- which(as.vector(lower.tri(diag(S),diag=T)))
    nK     <- length(Aindex)
    alphaVarGibbs <- matrix(0,ng,nK)
    colnames(alphaVarGibbs) <- .multivarChainNames(snames,snames)[Aindex] # half matrix
    
    toConsole( 'Note: Random groups', paste0( randGroups, collapse = ', '), verbose = verbose )
  }
    
  ################################## XL prediction: variables in both beta and rho
  
  Qall <- Q - 1
  
  # all terms
  linFactor <- numeric(0)
  lf <- factorBeta$linFactor
  xnAll <- unique( c(xnames, xlnames) )
  if( length(lf) > 0 ){
    for(k in 1:length(lf)){
      kf <- match(xnAll[lf[[k]]],colnames(xpred))
      linFactor <- append(linFactor,list(kf))
      names(linFactor)[length(linFactor)] <- names(factorBeta$linFactor)[k]
    }
  }
  
  if( termB & TIME ){
    
    tmp <- .xpredSetup(Y, x, bg, isNonLinX = interBeta$isNonLinX, 
                       factorObject = factorBeta, 
                       intMat = factorBeta$intMat, 
                       standMatSd = standMatSdB, standMatMu = standMatMuB, 
                       notOther, notStandardB ) 
    factorBeta$linFactor <- tmp$linFactor
    
    linFactorBeta <- numeric(0)
    lf <- factorBeta$linFactor
    if( length(lf) > 0 ){
      for(k in 1:length(lf)){
        kf <- match(xnames[lf[[k]]],colnames(xpred))
        linFactorBeta <- append(linFactorBeta,list(kf))
        names(linFactorBeta)[length(linFactorBeta)] <- names(factorBeta$linFactor)[k]
      }
    }
  }
  
  if( termR ){ 

    rho[ rho %in% c(-Inf, Inf) ] <- 0
    
    tmp <- .xpredSetup(Y, xx = xl, bgg = rho, 
                       isNonLinX = interRho$isNonLinX, 
                       factorObject = factorRho, 
                       intMat = interRho$intMat, 
                       standMatSd = standMatSdL, 
                       standMatMu = standMatMuL, 
                       notOther, notStandard = notStandardL ) 
     factorRho$linFactor <- tmp$linFactor
    
    linFactorRho <- numeric(0)
    lf <- factorRho$linFactor
    if( length(lf) > 0 ){
      for(k in 1:length(lf)){
        kf <- match(xlnames[lf[[k]]],colnames(xpred))
        linFactorRho <- append(linFactorRho,list(kf))
        names(linFactorRho)[length(linFactorRho)] <- names(factorRho$linFactor)[k]
      }
    }
  }
  
  ############  contrasts, predict F matrix
  
  if( termB ){
    tmp <- .setupFactors(xdata, xnames, factorBeta)
    ff  <- factorBeta[names(factorBeta) != 'factorList']
    factorBeta <- append(ff,tmp)
  }
  if( termR ){
    tmp <- .setupFactors(xdata, xlnames, factorRho)
    ff  <- factorRho[names(factorRho) != 'factorList']
    factorRho <- append(ff,tmp)
  }
  
  ############ sp richness
  richness <- richFull <- NULL
  RICHNESS <- F
  
  inRichness <- which(!typeNames %in% c('CON','CAT','OC'))
  inRichness <- inRichness[!inRichness %in% other]
  if(length(inRichness) > 2)RICHNESS  <- T
  
  wrich <- y*0 
  wrich[,inRichness] <- 1
  wrich[ymiss] <- 0
  
  ############ E matrix
  ess <- matrix(0,S,S)
  colnames(ess) <- rownames(ess) <- snames
  esens1 <- esens2 <- rep(0, S)
  
  fmat <- factorBeta$fmat
  fnames  <- rownames( factorBeta$lCont )                # variable names for centering
  
  if( termB & !TIME ){   # factors in all
    
    facNames <- names(factorBeta$factorList)
    fl <- character(0)
    for(k in 1:length(facNames)){
      kk <- which( startsWith( rownames(factorBeta$lCont), facNames[k] ) )
      fc <- rownames( factorBeta$lCont )[kk]
      fl <- c(fl, fc)
    }
  }
  
  if( termB & TIME ){   # factors in all
    
    fmat <- factorBeta$fmat
    fnames  <- rownames( factorBeta$lCont )  
    
    facNames <- names(factorBeta$factorList)
    if(!is.null(facNames)){
      fl <- character(0)
      for(k in 1:length(facNames)){
        
        kk <- which( startsWith( rownames(factorBeta$lCont), facNames[k] ) )
        fc <- rownames( factorBeta$lCont )[kk]
        fl <- c(fl, fc)
      }
      attr(bg, 'factors') <- facNames
      attr(bg, 'factorLevels') <- fl
    }
  }
  if( termR ){   # factors in all
    
    facNames <- names(factorRho$factorList)
    if(!is.null(facNames)){
      fl <- character(0)
      for(k in 1:length(facNames)){
        
        kk <- which( startsWith( rownames(factorRho$lCont), facNames[k] ) )
        fc <- rownames( factorRho$lCont )[kk]
        fl <- c(fl, fc)
      }
      attr(Rmat, 'factors') <- facNames
      attr(Rmat, 'factorLevels') <- fl
      attr(Rmat, 'formula') <- formulaRho
      factorRho$LCONT <- rep(TRUE, factorRho$nfact)
      flnames <- rownames( factorRho$lCont )
    }
    
    essL <- ess*0
    lsens1 <- lsens2 <- rep(0, S)
    RmatU <- Rmat
  }
  if( termA ){
    essA <- ess*0
    asens1 <- asens2 <- rep(0, S)
  }
  
  presence <- w*0
 
  covx <- cov(x)
  
  ############ sums
  xpred[,1] <- 1
  predx  <- predx2 <- xpred*0
  yerror <- ypred  <- ypred2 <- wpred  <- wpred2 <- ymissPred <- ymissPred2 <- y*0
  sumDev <- 0   #for DIC
  sMean  <- sg*0
  ntot   <- 0
  
  if(nmiss > 0){
    xmissSum <- xmissSum2 <- rep(0,nmiss)
  }
  
  predxl <- numeric(0)
  if(TIME & termR)predxl <- predxl2 <- xl*0
  
  ############################## gibbs chains
  
  q2 <- length(fnames)
  
  if(TRAITS){
    
    specTrait <- specByTrait[colnames(y),]
    tnames    <- colnames(specTrait)
    M         <- ncol(specTrait)
    specTrait <- t(specTrait)
    
    tpred  <- tpred2 <- matrix(0,n,M)
    
    missTrait <- which(is.na(specTrait),arr.ind=T)
    if(length(missTrait) > 0){
      traitMeans <- rowMeans(specTrait,na.rm=T)
      specTrait[missTrait] <- traitMeans[missTrait[,2]]
      warning( paste('no. missing trait values:',nrow(missTrait)) )
    }
    
    bTraitGibbs <- matrix(0,ng,M*Q)
    colnames(bTraitGibbs) <- .multivarChainNames(xnames,tnames)
    bTraitUnstGibbs <- bTraitGibbs
    
    bTraitFacGibbs <- matrix(0,ng,q2*M)
    colnames(bTraitFacGibbs) <- .multivarChainNames(fnames,tnames)
    
    mgibbs <- matrix(0,ng,M*M)
    colnames(mgibbs) <- .multivarChainNames(tnames,tnames)
  }
  
  if( termB ){
    
    bgibbsUn <- NULL
    
    bf <- .multivarChainNames(xnames, snames, keep = wB)
    
    bgibbs <- matrix(0, ng, length(bf) )
    colnames(bgibbs) <- bf
    if( length(standRows) > 0 ){
      bgibbsUn <- bgibbs                   # unstandardized
    }
    
    fbnames <- colnames( factorBeta$dCont )
    if(length(fbnames) > 0){
      bf <- .multivarChainNames( fbnames, snames[notOther] )
      bFacGibbs <- matrix(0, ng, length(bf))
      colnames(bFacGibbs) <- bf
      fSensGibbs <- matrix( 0, ng, length(fbnames) )
      colnames(fSensGibbs) <- fbnames
      covE <- cov( x[,xnames,drop=F]%*%factorBeta$dCont[xnames,fbnames] )  # note: x is standardized
    }
  }
  
  if( TIME ){
    
    yy <- y*0
    yy[rowInserts,] <- 1
    ymiss <- which(yy == 1, arr.ind=T)
    rm(yy)
    mmiss <- length(ymiss)
    
    if(termR){
      
      covL <- cov( xl%*%factorRho$dCont )  # note x is standardized
      nL  <- nrow(wL)
      
      lgibbs <- matrix(0, ng, nL)
      colnames(lgibbs) <- rownames(wL)
      lgibbsUn <- lgibbs                 # unstandardized
      spL <- rep(.01, nL)
    }
    
    if(termA){
      
      nA     <- nrow(wA)
      wnames <- apply(wA, 1, paste0, collapse='-')  #locations in Amat, not alpha
      alphaGibbs <- matrix(0, ng, nA)
      colnames(alphaGibbs) <- wnames
      spA <- rep(.001, nA)
    }
    
    ni <- length(i1)
    g1 <- 1
    gcheck <- c(50, 100, 200, 400, 800)
    tinyg <- 1e-6
  }
  
  pbar <- txtProgressBar(min=1,max=ng,style=1)
  
  form <- formula
  if( !is.null(formulaBeta) )form <- formulaBeta
  tmp <- .getUnstandX(form, x[,xnames, drop=F], xdata, standRows )
  S2U      <- tmp$S2U                    # S2U%*%*bg
  xUnstand <- tmp$xu
  
  
  if( Q == 1 )PREDICTX <- FALSE
  
  if(TIME & termB){
    tmp <- .getUnstandX(formulaBeta, x[,xnames, drop=F], xdata, standRowsB )
    S2U <- tmp$S2U
  }
  
  if(termR){
    facNamesRho <- attr(Rmat, 'factors') 
  #  xf  <- NULL
  #  if(length(facNames) > 0){
  #    xf <- xdata[, facNamesRho, drop=F]
  #  }
    
    tmp <- .getUnstandX( formulaRho, xl, xdata, standRowsL )
    S2UL      <- tmp$S2U
    xlUnstand <- tmp$xu
    missR <- which( is.na(xlUnstand), arr.ind=T )
    missXR <- unique(missR[,1])
    if(length(missR) > 0){
      xlmu <- colMeans(xlUnstand, na.rm=T)
      xlUnstand[missR] <- xlmu[ missR[,2] ]
    }
  }
  
  if(REDUCT)rndTot <- rndTot2 <- w*0 
  notPA <- which(!typeNames == 'PA' & !typeNames == 'CON')
    
  if(length(y) < 10000 | FULL) FULL <- T
  
  if(FULL){
    ygibbs <- matrix(0,ng,length(y))
  }
  if(RICHNESS){
    ypredPres <- ypredPres2 <- ypredPresN <- y*0
    shannon   <- rep(0,n)
  }

  varExp <- varTot <- varExpMean <- varExpRand <- rep( 0, length(notOther) )
  
  sdg <- .1
  
  
    
  for(g in 1:ng){ ########################################################
    
    if( REDUCT ){
      
      Y  <- w[,notOther]
      
      if(TIME){
        Y[tindex[,1],] <- w[tindex[,2],notOther] - w[tindex[,1],notOther]   # delta w here
        Y <- Y - mua[,notOther] - mug[,notOther] 
      }
      if(RANDOM)Y <- Y - groupRandEff[,notOther] 
      
      tmp <- .param.fn(X = x[drop=F,,xnames], beta = bg[drop=F,,notOther], Y = Y, otherpar) 
      sg[notOther,notOther] <- tmp$sg
      otherpar              <- tmp$otherpar
      rndEff[inSamples,notOther] <- tmp$rndEff
      sigmaerror          <- otherpar$sigmaerror
      kgibbs[g,notOther]  <- otherpar$K
      sgibbs[g,]          <- as.vector(otherpar$Z)
      sigErrGibbs[g]      <- sigmaerror
      sg[sgOther]         <- .1*sigmaerror
      
      sinv <- .invertSigma(sg[notOther,notOther],sigmaerror,otherpar,REDUCT)
      sdg  <- sqrt(sigmaerror)
      
      if( !TIME ){
        
        Y <- w[inSamp,notOther] - rndEff[inSamp,notOther]
        if(RANDOM)Y <- Y - groupRandEff[inSamp,notOther]
        bg[,notOther] <- updateBeta(X = x[inSamp,xnames], Y, 
                                    sig = sigmaerror, beta = bg[,notOther],
                                    PRIOR = BPRIOR, lo=loB[,notOther], hi=hiB[,notOther])
        muw[inSamp,] <- x[inSamp,]%*%bg
        
      } else {  # REDUCT and TIME
        
        mua <- mug <- w*0
        if(termA)mua  <- Umat%*%Amat 
        if(termR)mug  <- Vmat%*%Rmat
        
        Y[tindex[,1],] <- w[tindex[,2],notOther] - w[tindex[,1],notOther]   # delta w here
        
        if( termB ){
          
          if( termR )Y <- Y - mug[,notOther] 
          if( termA )Y <- Y - mua[,notOther] 
          if(RANDOM) Y <- Y - groupRandEff[,notOther]
          Y <- Y - rndEff[,notOther]
          
          bg[,notOther] <- updateBeta( X = x[drop=F, tindex[,1],xnames], Y = Y[tindex[,1],], 
                                       sig = sigmaerror, beta = bg[,notOther],
                                       PRIOR = BPRIOR,
                                       rows = Brows, pattern = Bpattern,
                                       lo=loB[,notOther], hi=hiB[,notOther],
                                       wF = wB )
          mub <- x[,xnames]%*%bg
        }else{
          mub <- 0
        }
        
        if( termR ){
          
          Y[tindex[,1],] <- w[tindex[,2],notOther] - w[tindex[,1],notOther]   # delta w here
          if( termB )Y <- Y - mub[,notOther] 
          if( termA )Y <- Y - mua[,notOther] 
          if(RANDOM) Y <- Y - groupRandEff[,notOther]
          Y <- Y - rndEff[,notOther]
          
          Rmat[,notOther] <- updateBeta( X = Vmat[tindex[,1],], 
                                         Y = Y[tindex[,1],notOther], sig=sigmaerror, 
                                         beta = Rmat[,notOther], PRIOR = LPRIOR,
                                         rows = Rrows, pattern = Rpattern, 
                                         lo = loRmat, hi = hiRmat, wF = wL )
          mug  <- Vmat%*%Rmat
        }else{
          mug <- 0
        }
        
        if( termA ){
          
          Y[tindex[,1],] <- w[tindex[,2],notOther] - w[tindex[,1],notOther]   # delta w here
          if( termB )Y <- Y - mub[,notOther] 
          if( termR )Y <- Y - mug[,notOther] 
          if(RANDOM) Y <- Y - groupRandEff[,notOther]
          Y <- Y - rndEff[,notOther]         
          
          Amat[,notOther] <- updateBeta(X = Umat[tindex[,1],], Y = Y[tindex[,1],], sig = sigmaerror, 
                                        rows = Arows, pattern = Apattern, 
                                        beta = Amat[,notOther], PRIOR = TRUE, 
                                        lo = loAmat[,notOther], hi = hiAmat[,notOther], wF = wA )
          mua <- Umat%*%Amat
        }else{
          mua <- 0
        }
        muw <- mub + mug + mua + rndEff
      }
      
    } else { 
      
      # !REDUCT 
      
      if( !TIME ){
        
        Y <- w[inSamp,notOther]
        if(RANDOM)Y <- Y - groupRandEff[inSamp,notOther]
        bg[,notOther] <- updateBeta(X = x[inSamp,], Y, sig = sg[notOther,notOther], 
                                    beta = bg[,notOther], BPRIOR, lo=loB, hi=hiB)
        muw[inSamp,] <- x[inSamp,]%*%bg
        
      }else{ 
        
        # !REDUCT & TIME
        
        muw <- mub <- mua <- mug <- w*0
        
        if( termR )mug  <- Vmat%*%Rmat
        if( termA )mua  <- Umat%*%Amat 
        
        if( termB ){
          
          Y   <- w[,notOther] 
          Y[tindex[,1],] <- w[tindex[,2],] - w[tindex[,1],notOther]
          if(termA) Y <- Y - mua[,notOther] 
          if(termR) Y <- Y - mug[,notOther]
          if(RANDOM)Y <- Y - groupRandEff[,notOther]
          
          bg[,notOther] <- updateBeta(X = x[drop=F, tindex[,1],xnames], Y = Y[tindex[,1],notOther], 
                                      sig = sg[notOther,notOther], beta = bg[,notOther],
                                      PRIOR = BPRIOR,
                                      rows = Brows, pattern = Bpattern,
                                      lo=loB[,notOther], hi=hiB[,notOther], sinv = sinv, wF = wB)
          mub[tindex[,1],] <- x[tindex[,1],xnames]%*%bg
          mub[timeLast,]   <- x[drop=F, timeLast,xnames]%*%bg
          muw <- muw + mub
        }
        
        if( termR ){
          
          Y   <- w[,notOther] 
          Y[tindex[,1],] <- Y[tindex[,2],] - w[tindex[,1],notOther]
          if(termA) Y <- Y - mua[,notOther] 
          if(termB) Y <- Y - mub[,notOther]
          if(RANDOM)Y <- Y - groupRandEff[,notOther]
          
          Rmat[,notOther] <- updateBeta(X = Vmat[tindex[,1],], Y = Y[tindex[,1],], 
                                        sig=sg[notOther,notOther], 
                                        beta = Rmat[,notOther],
                                        PRIOR = LPRIOR,
                                        rows = Rrows, pattern = Rpattern, 
                                        lo = loRmat, hi = hiRmat, sinv = sinv, wF = wL)
          
       #############   diag(Rmat) <- diag(rho)
          
          mug[tindex[,1],] <- Vmat[tindex[,1],]%*%Rmat
          mug[timeLast,]   <- Vmat[drop=F, timeLast,]%*%Rmat
          muw <- muw + mug
        }
        
        
        
        if(termA){
          
          Y   <- w[,notOther] 
          Y[tindex[,1],] <- Y[tindex[,2],] - w[tindex[,1],notOther]
          if(termR) Y <- Y - mug[,notOther] 
          if(termB) Y <- Y - mub[,notOther]
          if(RANDOM)Y <- Y - groupRandEff[,notOther]
          
          Amat[,notOther] <- updateBeta(X = Umat[tindex[,1],], Y = Y[tindex[,1],], 
                                        sig=sg[notOther,notOther], 
                                        beta = Amat[,notOther], PRIOR = TRUE,
                                        lo=loAmat[,notOther], hi=hiAmat[,notOther], 
                                        rows = Arows, pattern = Apattern, sinv = sinv, wF = wA)
          
     #     Amat[wA] <- alpha[aindex]
          
          
          
          mua[tindex[,1],] <- Umat[tindex[,1],]%*%Amat
          mua[timeLast,] <- Umat[drop=F, timeLast,]%*%Amat
          muw[,notOther] <- muw[,notOther] + mua[,notOther]
        }
        
        Y    <- w
        Y[tindex[,1],] <- w[tindex[,2],] - w[tindex[,1],]
        SS   <- crossprod(Y[tindex[,1],notOther] - muw[tindex[,1],notOther])
        SI   <- solveRcpp(SS)
      }
      
      
      if( !TIME ){
        
        # !REDUCT & !TIME, marginalize parameter matrix
        
        Y <- w[inSamp,notOther]
        if(RANDOM)Y <- Y - groupRandEff[inSamp,notOther]
        XIXXX <- x[drop=F, inSamp,]%*%solveRcpp( crossprod(x[drop=F, inSamp,]) )%*%t(x[drop=F, inSamp,] )
        XUV   <- t(Y)%*%XIXXX%*%Y
        YX    <- crossprod(Y) - XUV
        SI    <- solve( YX ) 
      }
      sinv <- .rwish(sigmaDf, SI)
      sg[notOther,notOther] <- solveRcpp(sinv)
      sgibbs[g,] <- sg[Kindex]
    }
    
    if(termB)alphaB <- .sqrtMatrix(bg, sg, DIVIDE=T)
    
    if( 'OC' %in% typeCode ){
      tg <- .updateTheta(w, tg, cutLo, cutHi, ordCols,
                         holdoutN, holdoutIndex, minOrd, maxOrd) # var scale
      if(TIME){
        cutg <- tg
      }else{
        cutg <- .gjamCuts2theta(tg, ss = sg[ordCols,ordCols]) # corr scale
      }
      breakMat[ordCols,1:lastOrd] <- cutg
      cgibbs[g,] <- as.vector( cutg[,-c(1,2,ncut)] )
      
      plo[,ordCols] <- cutg[cutLo]
      phi[,ordCols] <- cutg[cutHi]
    }
    
    if(RANDOM){
      
      cw <- w - muw
      
      if( TIME ){
        cw[tindex[,1],] <- w[tindex[,2],] - w[tindex[,1],] - muw[tindex[,2],]
      }
      
      if(REDUCT){
        cw <- cw - rndEff
        v  <- 1/sigmaerror*.byGJAM(as.vector(cw), randGroupIndex[,1], 
                                   randGroupIndex[,2], alphaRandGroup*0, 
                                   fun='sum')[notOther,]
        sinv <- diag(1/sigmaerror, SO)
      }else{
        v <- .byGJAM(as.vector(cw), randGroupIndex[,1], 
                     randGroupIndex[,2], alphaRandGroup*0, fun='sum')[notOther,]
        v <- sinv%*%v
      }
      
      alphaRandGroup[notOther,] <- randEffRcpp(v, randGroupTab, sinv, CImat)
      if(length(other) > 0)alphaRandGroup[other,] <- 0
      if(g < 10){
        alphaRandGroup[notOther,] <- 
          sweep( alphaRandGroup[notOther,], 2, 
                 colMeans(alphaRandGroup[notOther,]), '-')
      }
      SS  <- crossprod(t(alphaRandGroup[notOther,]))
      SS  <- S*SS + Cmat
      
      testv <- try( chol(SS) ,T)
      if( inherits(testv,'try-error') ){
        tiny  <- .01*diag(SS)
        SS  <- SS + diag(diag(SS + tiny))
      }
      
      Ckeep[notOther,notOther] <- .riwish( df = S*G + 1, SS )
      CImat <- solveRcpp(Ckeep[notOther,notOther])
      
      alphaVarGibbs[g,] <- Ckeep[Aindex]
      groupRandEff <- t(alphaRandGroup)[groupIndex,]
    }
    
    if( TIME ){
      
      # muw does not include rndEff or groupRandEff
      tmp <- .updateW(w, plo, phi, wpropTime, xl, yp, Rmat, Amat, rndEff, groupRandEff,
                      sdg, muw, mub, Umat, Vmat, sinv)
      w <- tmp$w; muw <- tmp$muw; yp <- tmp$yp; Umat <- tmp$Umat; Vmat <- tmp$Vmat
      
      groups <- NULL
      
      for(k in allTypes){
        
        wk <- which(typeCols == k)
        nk <- length(wk)
        wo <- which(wk %in% notOther)
        wu <- which(typeCols[notOther] == k)
        wp <- w[, wk, drop=F]
        yp <- yp[, wk, drop=F]
        yy <- y[,wk,drop=F]
        
        if(typeFull[wk[1]] == 'countComp')groups <- CCgroups
        if(typeFull[wk[1]] == 'fracComp')groups  <- FCgroups
        if(typeFull[wk[1]] == 'categorical')groups <- CATgroups
        
        glist <- list(wo = wo, type = typeFull[wk[1]], yy = yy, 
                      wq = wp, yq = yp, cutg = cutg, 
                      censor = censor, censorCA = censorCA, 
                      censorDA = censorDA, censorCON  = censorCON, 
                      eff = effMat[,wk,drop=F], groups = groups, 
                      k = k, typeCols = typeCols, notOther = notOther, 
                      wk = wk, sampW = sampleW[,wk])
        tmp <- .gjamWLoopTypes( glist )
        w[,wk]  <- tmp[[1]]
        yp[,wk] <- tmp[[2]]
      }
      
      # predict X: this changes x and Vmat
      
      if( ncol(x) > 1 ){ # do not predict intercept
        
        xtmp <- xpred
        xtmp[,-1] <- .tnorm(n*Qall, -3, 3, xpred[,-1], .1)
        
        # factors
        if( length(linFactor) > 0 ){
          for(k in 1:length(linFactor)){
            mm  <- linFactor[[k]]
            wcol <- sample(mm,n,replace=T)
            xtmp[,mm[-1]] <- 0
            xtmp[ cbind(1:n, wcol) ] <- 1
          }
        }
        
        if(length(intMat) > 0){     #  interactions
          xtmp[,intMat[,1]] <- xtmp[,intMat[,2]]*xtmp[,intMat[,3]]
        }
        
        muNow <- muNew <- w*0 + rndEff
        
        if(termB){
          muNow[,notOther]  <- muNow[,notOther] + xpred[drop=F, , xnames]%*%bg[,notOther,drop=F]
          muNew[,notOther]  <- muNew[,notOther] + xtmp[drop=F, , xnames]%*%bg[,notOther,drop=F]
        }
        if(termA){
          mua   <- Umat%*%Amat
          muNow[,notOther] <- muNow[,notOther] + mua[,notOther]
          muNew[,notOther] <- muNew[,notOther] + mua[,notOther]
        }
        if(termR){  # note: Vmat holds w[t-1,]*x[t,]
          ww <- w
          ww[ww < 0] <- 0
          Vnow <- Vnew <- Vmat
          Vnow[tindex[,1],]  <- ww[drop = FALSE,tindex[,1],gindex[,'colW']]*
            xpred[drop = FALSE,tindex[,1],xlnames][drop = FALSE,,gindex[,'rowG']]
          mugNow <- Vnow%*%Rmat
          muNow[,notOther]  <- muNow[,notOther] + mugNow[,notOther]
          
          Vnew[tindex[,1],] <- ww[drop = FALSE,tindex[,1],gindex[,'colW']]*
            xtmp[drop = FALSE,tindex[,1],xlnames][drop = FALSE,,gindex[,'rowG']]
          mugNew <- Vnew%*%Rmat
          muNew[,notOther]  <- muNew[,notOther] + mugNew[,notOther]
        }
        
        ww <- w
        ww[tindex[,1],] <- ww[tindex[,2],] - ww[tindex[,1],]
        ww[timeZero,] <- ww[timeZero+1,]
        ww[timeLast,] <- ww[timeLast-1,]
        
        if(REDUCT){
          pnow <- dnorm(ww[,notOther],muNow[,notOther],sdg,log=T)
          pnew <- dnorm(ww[,notOther],muNew[,notOther],sdg,log=T)
          a1   <- exp( rowSums(pnew - pnow) )
        }else{
          pnow <- .dMVN(ww[,notOther],muNow[,notOther],smat=sg,log=T) 
          pnew <- .dMVN(ww[,notOther],muNew[,notOther],smat=sg,log=T) 
          a1   <- exp(pnew - pnow)
        }
        z    <- runif( length(a1), 0, 1 )
        za   <- which(z < a1)
        if( length(za) > 0 ){
          xpred[za,] <- xtmp[za,]
        }
        if( termR ){
          if(nlmiss > 0)xl[xlmiss] <- xpred[,colnames(xl)][xlmiss]
        }
        if( nmiss > 0 ){
          
          x[xmiss] <- xpred[xmiss]
          
     #     xf  <- NULL
     #     if( length(facNames) > 0 ){
     #       xf <- xdata[drop=F,, facNames]
     #     }
     #     tmp    <- .getUnstandX(formula, x[drop=F,,xnames], xdata, standRows )            
     #     S2U    <- tmp$S2U
     #     XX     <- crossprod(x)
     #     IXX    <- solveRcpp(XX)
        }
      }
      
    }else{ ############# not TIME
      
      # ww <- x%*%bg + rmvnormRcpp(nrow(w), rep(0, S), sg)
      
      tmp   <- .updateW( rows=1:nrow(x), x, w, y, bg, sg, alpha=alphaB, 
                         cutg, plo, phi, rndEff, groupRandEff, 
                         sigmaerror, wHold )
      w     <- tmp$w
      yp    <- tmp$yp
   #   plo   <- tmp$plo
   #   phi   <- tmp$phi
      wHold <- tmp$wHold    #values for w if not held out
      
      Y <- w[,notOther]
      if(holdoutN > 0) Y[holdoutIndex,] <- wHold[,notOther]  # if w not held out
      if(RANDOM)Y <- Y - groupRandEff[,notOther]
      
      if(nmiss > 0){
        
        x[xmiss] <- .imputX_MVN(x,Y,bg[,notOther],xmiss,sinv,xprior=xprior,
                                xbound=xbound)[xmiss]
        if( length(standRows) > 0 ){
          
     #     xf  <- NULL
     #     if(length(facNames) > 0){
     #       xf <- xdata[, facNames, drop=F]
     #     }
     #     tmp    <- .getUnstandX( formula, x, xdata, standRows )            
     #     S2U    <- tmp$S2U
     #     XX     <- crossprod(x)
     #     IXX    <- solveRcpp(XX)
        }
      }
      
      if( PREDICTX & length(predXcols) > 0 ){
        
        if( length(interBeta$isNonLinX) > 0 ){
          
          xpred <- .predictY2X_nonLinear(xpred, yy=Y, bb=bg[,notOther],
                                         ss=sg[notOther,notOther],
                                         priorIV = priorXIV, priorX=priorX,
                                         factorObject = factorBeta, interObject = interBeta,
                                         lox, hix, propx)$x   
        }
        
        if( length(px) > 0 ){
          
          wn <- which(!is.finite(xpred),arr.ind=T)
          if(length(wn) > 0){
            tmp <- matrix(priorX,Q,nrow(wn))
            xpred[wn[,1],] <- t(tmp)
          }
          xpred[,px] <- .predictY2X_linear(xpred, yy=Y, bb=bg[,notOther],
                                           ss=sg[notOther,notOther], sinv = sinv,
                                           priorIV = priorXIV, 
                                           priorX=priorX, predCols=px, 
                                           REDUCT=REDUCT, lox, hix, propx)[,px]
          wn <- which(!is.finite(xpred),arr.ind=T)
          if(length(wn) > 0){
            tmp <- matrix(priorX,Q,nrow(wn))
            xpred[wn[,1],] <- t(tmp)
          }
        }
        
        if( length(factorBeta$linFactor) > 0 ){
          
          # predict all factors
          xtmp <- xpred
          xtmp[,factorBeta$findex] <- 
            .predictY2X_linear(xpred, yy=Y, 
                               bb=bg[,notOther],
                               ss=sg[notOther,notOther], sinv = sinv,
                               priorIV = priorXIV, 
                               priorX=priorX,predCols=factorBeta$findex, 
                               REDUCT=REDUCT, lox, hix, propx)[,factorBeta$findex]
          for(k in 1:length(factorBeta$linFactor)){
            
            mm  <- factorBeta$linFactor[[k]]
            tmp <- xtmp[,mm]
            
            tmp[,1] <- 0
            ix  <- apply(tmp,1,which.max)   
            
            tmp <- tmp*0
            tmp[ cbind(1:n,ix) ] <- 1
            tmp <- tmp[,-1,drop=F]
            xpred[,mm[-1]] <- tmp
          }
        }
        xpred[,1] <- 1
      }
    }
    
    
    setTxtProgressBar(pbar,g)
    
    if(termR){
 #     rho[ gindex[,c('rowG','colW')] ] <- Rmat[wL]
      lgibbs[g,] <- Rmat[wL]       # standardized
    }
    
    if(termA)alphaGibbs[g,] <- Amat[wA]
    
    if(termB)bgibbs[g,] <- bg[wB] # standardized, except nonStandard columns, 
    
    # unstandardize if there are standardized columns; otherwise bgibbs is unstandardized
    
    if( length(standRows) > 0 ){           # for xUnstand
      if( termB ){
        bgU <- S2U%*%bg
        bgibbsUn[g,] <- bgU[wB]
      }
    }
    
    if( TIME ){
      
      if( termR & length(standRowsL) > 0 ){
        
        if( ncol(xl) > 1 ){
          
          Vunst <- Vmat
          wz    <- w
          wz[wz < 0] <- 0
          Vunst[tindex[,1],]  <- wz[drop = FALSE,tindex[,1],gindex[,'colW']]*
            xlUnstand[drop = FALSE,tindex[,1],xlnames][drop = FALSE,,gindex[,'rowG']]
          
          Y   <- w[,notOther] 
          Y[tindex[,1],] <- Y[tindex[,2],] - w[tindex[,1],]
          if(termA) Y <- Y - mua[,notOther] 
          if(termB) Y <- Y - mub[,notOther]
          if(REDUCT)Y <- Y - rndEff[,notOther]
          if(RANDOM)Y <- Y - groupRandEff[,notOther]
          
          sig <- sigmaerror
          if( !REDUCT ) sig <- sg[notOther,notOther]
          
          RmatU[,notOther] <- updateBeta( X = Vunst[tindex[,1],], 
                                          Y = Y[tindex[,1],notOther], sig = sig, 
                                          beta = RmatU[,notOther],
                                          PRIOR = LPRIOR,
                                          rows = Rrows, pattern = Rpattern, 
                                          lo = loRmat, hi = hiRmat, sinv = sinv, wF = wL )
          
          lgibbsUn[g,] <- RmatU[wL]          # unstandardized
        }
      }
    }
    
    if( TRAITS ){
      Atrait <- bgU%*%t(specTrait[,colnames(yp)])  # unstandardized
      bTraitUnstGibbs[g,] <- Atrait
      
      Atrait <- bg%*%t(specTrait[,colnames(yp)])  # standardized
      bTraitGibbs[g,] <- Atrait
      
      Strait <- specTrait[,colnames(yp)]%*%sg%*%t(specTrait[,colnames(yp)])
      mgibbs[g,] <- Strait
      
      minv <- ginv(Strait)
      
      tmp <- .contrastCoeff(beta=Atrait, 
                            notStand = notStandard[notStandard %in% xnames], 
                            sigma = Strait, sinv = minv,
                            stand = standMatSd, factorObject=factorBeta )
      tagg   <- tmp$ag
      bTraitFacGibbs[g,] <- tagg # stand for X and W, centered for factors
    }
    
    if( termB & !is.null(fSensGibbs) ){
      
      # Fmatrix centered for factors, 
      # bg is standardized by x, bgu is unstandardized
      
      nst <- notStandard[notStandard %in% xnames]
      stm <- standMatSd
      if(TIME){
        nst <- notStandardB[notStandard %in% xnames]
        stm <- standMatSdB
      }
      
      tmp <- .contrastCoeff(beta=bg[,notOther, drop=F], 
                            notStand = nst, 
                            sigma = sg[notOther,notOther], sinv = sinv,
                            stand = stm, factorObject=factorBeta )
      agg   <- tmp$ag  
      beg   <- tmp$eg
      fsens <- tmp$sens
      fsens[ fsens < 1e-12 ] <- 0
      
      fSensGibbs[g,]  <- sqrt(diag(fsens))[fbnames]
      bFacGibbs[g,] <- agg                 # stand for X and W, centered for factors
    }
    
    if(FULL)ygibbs[g,] <- as.vector(yp)
    
    if(g > burnin){
      
      ntot   <- ntot + 1
      ypred  <- ypred + yp
      ypred2 <- ypred2 + yp^2
      
      wpr  <- matrix( colMeans( w[inSamp, notOther] ), length(inSamp), length(notOther),
                      byrow = T )
      tss  <- diag( crossprod( w[inSamp,notOther] - wpr ) ) # total
      vtot <- diag( var(w[inSamp,notOther]) ) 
      
      if( termB ){
        mpr  <- x[inSamp,xnames]%*%bg[,notOther, drop=F]
        mtot <- diag( var(mpr))
        varExpMean <- varExpMean + mtot/vtot
        rss    <- diag( crossprod( w[inSamp,notOther] - mpr ) ) # residual
        vexp   <- 1 - rss/tss
        varExp <- varExp + vexp
      }
      
      varTot <- varTot + vtot
      
      if(RANDOM){
        itot <- diag(var(groupRandEff[inSamp,notOther])) 
        varExpRand <- varExpRand + itot/vtot
      }
      
      tmp <- .dMVN(w[,notOther], muw[,notOther], sg[notOther,notOther], log=T)
      sumDev <- sumDev - 2*sum(tmp) 
      yerror <- yerror + (yp - y)^2
      
      if( termB & !is.null(fSensGibbs) )fmat <- fmat + fsens
      
      sMean  <- sMean + sg
      
      wpred  <- wpred + w
      wpred2 <- wpred2 + w^2
      
      if(RICHNESS){
     
        yy <- yp
        
        if('PA' %in% typeNames){
          wpa <- which(typeNames[inRichness] == 'PA')
          yy[,inRichness[wpa]] <- round(yp[,inRichness[wpa]]) #######
        }
        
        if(length(notPA) > 0){
          w0 <- which(yy[,notPA] <= 0)
          w1 <- which(yy[,notPA] > 0)
          yy[,notPA][w0] <- 0
          yy[,notPA][w1] <- 1
        }
        
        shan <- sweep(yp[,inRichness], 1, rowSums(yp[,inRichness]), '/')
        shan[shan == 0] <- NA
        shan <- -rowSums(shan*log(shan),na.rm=T)
        shannon <- shannon + shan
        
        wpp <- which(yy > 0)
        ypredPres[wpp]  <- ypredPres[wpp] + yp[wpp]
        ypredPres2[wpp] <- ypredPres2[wpp] + yp[wpp]^2
        ypredPresN[wpp] <- ypredPresN[wpp] + 1
        
        presence[,inRichness] <- presence[,inRichness] + yy[,inRichness]
        ones <- round(rowSums(yy[,inRichness]))
        more <- round(rowSums(yy[,inRichness]*wrich[,inRichness,drop=F]))
        richFull <- .add2matrix(ones,richFull)
        richness <- .add2matrix(more,richness)  # only for non-missing
      }
      
      if(RANDOM){
        alphaRanSums  <- alphaRanSums + alphaRandGroup
        alphaRanSums2 <- alphaRanSums2 + alphaRandGroup^2
      }
      
      if(mmiss > 0){
        ymissPred[ymiss]  <- ymissPred[ymiss] + y[ymiss]
        ymissPred2[ymiss] <- ymissPred2[ymiss] + y[ymiss]^2
      }
      if(nmiss > 0){
        xmissSum  <- xmissSum + x[xmiss]
        xmissSum2 <- xmissSum2 + x[xmiss]^2
      }
      
      if(PREDICTX & length(predXcols) > 0){
        predx  <- predx + xpred
        predx2 <- predx2 + xpred^2
      }
      
      wa0 <- numeric(0)
      
      if( !is.null(fSensGibbs) ){
        if( !TIME | (TIME & termB) ){
          
          ag <- agg
          cx <- t(ag)%*%covE%*%ag 
          ess[notOther,notOther]  <- ess[notOther,notOther] + cx
          
          esd <- sqrt(diag(cx))
          esens1[notOther] <- esens1[notOther] + esd
          esens2[notOther] <- esens2[notOther] + esd^2
        }
      }
      
      if( termR){
        
        if(ncol(xl) > 1 ){
          
          # variables in Vmat are standardized
          covL <- cov(Vmat)
          cp   <- t(Rmat[,notOther,drop=F])%*%covL%*%Rmat[,notOther,drop=F]
          essL[notOther,notOther]  <- essL[notOther,notOther] + cp
          
          lsd <- sqrt(diag(cp))
          lsens1[notOther] <- lsens1[notOther] + lsd
          lsens2[notOther] <- lsens2[notOther] + lsd^2
        }
      }
      
      if(termA){
        
        covw <- cov(Umat)
        ca   <- t(Amat[,notOther])%*%covw%*%Amat[,notOther]
        essA[notOther,notOther]  <- essA[notOther,notOther] + ca
        
        asd <- sqrt(diag(ca))
        asens1[notOther] <- asens1[notOther] + asd
        asens2[notOther] <- asens2[notOther] + asd^2
      }
      
      
      if(REDUCT){
        rndTot  <- rndTot + rndEff
        rndTot2 <- rndTot2 + rndEff^2
      }
      
      if(TRAITS){
        yw     <- sweep(yp,1,rowSums(yp),'/')
        yw[yw <= 0]   <- 0
        yw[is.na(yw)] <- 0
        Ttrait <- .gjamPredictTraits(yw,specTrait[,colnames(yp)], traitTypes)
        tpred  <- tpred + Ttrait
        tpred2 <- tpred2 + Ttrait^2
      }
    } 
  
        
  }
  ################# end gibbs loop ####################
  
  
  # default: all columns standardized for analysis
  #          reported on input scale in betaMu, bgibbsUn
  #          reported on standardized scale in betaStandXmu, bgibbs
  #          reported on standardized X, correlation Y in betaStandXWmu
  #    S2U:  unstandardized beta is S2U%*%bg 
  # if( length(standRows) > 0 ) then there are standardized variables to be 
  #                             unstandardized in bgibbsUn
  
  # notStandard: columns that are are not standardized for the analysis in x
     
  otherpar$S <- S 
  otherpar$Q <- Q
  otherpar$snames <- snames
  otherpar$xnames <- xnames
  
  presence <- presence/ntot
  
  if(RICHNESS){
    missRows <- sort(unique(ymiss[,1]))
    richNonMiss <- richness/ntot            #only non-missing plots
    yr  <- as.matrix(ydata[,inRichness]) 
    yr[yr > 0] <- 1
    yr <- rowSums(yr,na.rm=T)
    vv  <- matrix(as.numeric(colnames(richNonMiss)),n,
                  ncol(richNonMiss),byrow=T)
    rmu <- rowSums( vv * richNonMiss )/rowSums(richNonMiss)
    
    rsd <- sqrt( rowSums( vv^2 * richNonMiss )/rowSums(richNonMiss) - rmu^2)
    
    vv  <- matrix(as.numeric(colnames(richFull)),n,ncol(richFull),byrow=T)
    rfull <- rowSums( vv * richFull )/rowSums(richFull)
    rfull[missRows] <- NA
    rmu <- rowSums(presence)
    
    shan <- sweep(y[,inRichness], 1, rowSums(y[,inRichness]), '/')
    shan[shan == 0] <- NA
    shanObs <- -rowSums(shan*log(shan),na.rm=T)
    
    richness <- cbind(yr, rmu, rsd, rfull, shanObs, shannon/ntot )
    colnames(richness) <- c('obs','predMu','predSd','predNotMissing',
                            'H_obs', 'H_pred')
    if(TIME)richness[timeZero,] <- NA
    
    ms <- sums2meanSd( ypredPres, ypredPres2, ypredPresN )  # predictive mean and se given presence
    ypredPresMu <- ms$mean
    ypredPresSe <- ms$sd
  }
  
  if('OC' %in% typeNames){
    ordMatShift <- matrix(ordShift,n,length(ordCols),byrow=T)
    onames <- snames[ordCols]
    wb <- match(paste(onames,'intercept',sep='_'), colnames(bgibbs))
    bgibbs[,wb]   <- bgibbs[,wb] + matrix(ordShift,ng,length(ordCols),byrow=T)
    if( !is.null(bgibbsUn)){
      bgibbsUn[,wb] <- bgibbsUn[,wb] + matrix(ordShift,ng,length(ordCols),byrow=T)
    }
    y[,ordCols] <- y[,ordCols] + ordMatShift
  }
    
  if(mmiss > 0){
    ymissPred[ymiss]  <- ymissPred[ymiss]/ntot
    yd <- ymissPred2[ymiss]/ntot - ymissPred[ymiss]^2
    yd[!is.finite(yd)| yd < 0] <- 0
    ymissPred2[ymiss] <- sqrt(yd)
    
    if('OC' %in% typeNames){
      ymissPred[,ordCols] <- ymissPred[,ordCols] + ordMatShift
    }
  }
  
  rmspeBySpec <- sqrt( colSums(yerror)/ntot/n )
  rmspeAll    <- sqrt( sum(yerror)/ntot/n/S )
  
  sMean <- sMean/ntot
  
  varMu <- 0
  if( termB ){
    varExp <- varExp/ntot
    varMu  <- varExpMean/ntot
  }
  varTot <- varTot/ntot
  varRn  <- varExpRand/ntot
  varMod <- varMu + varRn
  
  betaStandXWmu <-  betaStandXWse <- betaStandXWTable <- NULL
  
  if(termB){
    
    betaStandXmu  <- betaStandXse  <- betaStandXTable <- NULL
    betaStandXWmu <- betaStandXWse <- betaStandXWTable <- NULL
    
    tmp <- .chain2tab(bgibbs[burnin:ng,], snames, xnames, wF = wB)
    betaStandXmu <- tmp$mu
    betaStandXse <- tmp$se
    betaStandXTable <- tmp$tab
    
    if( !is.null(bFacGibbs) ){
      tmp <- .chain2tab(bFacGibbs[burnin:ng,], snames[notOther], rownames(agg))
      betaStandXWmu    <- tmp$mu
      betaStandXWse    <- tmp$se
      betaStandXWTable <- tmp$tab
    }
    
    if(!is.null(loB)){
      blo <- as.vector( t(loB) )
      bhi <- as.vector( t(hiB) )
   #   names(blo) <- names(bhi) <- bf
      bprior <- cbind(blo[rownames(betaStandXTable)],
                      bhi[rownames(betaStandXTable)])
      colnames(bprior) <- c('priorLo','priorHi')
      betaStandXTable <- cbind(betaStandXTable[,1:4], bprior) 
    }
    
    if( length(standRows) > 0 ){
      tmp <- .chain2tab(bgibbsUn[burnin:ng,], snames, xnames, wF = wB)
      betaMu    <- tmp$mu
      betaSe    <- tmp$se
      betaTable <- tmp$tab
      
    }else{
      betaMu    <- betaStandXmu
      betaSe    <- betaStandXse
      betaTable <- betaStandXTable
      
      betaWMu    <- betaStandXWmu
      betaWSe    <- betaStandXWse
      betaWTable <- betaStandXWTable
    }
    if( !is.null(bFacGibbs) ){
      tmp <- .chain2tab(bFacGibbs[burnin:ng,,drop=F])
      sensTable <- tmp$tab[,1:4]
    }
  }
  
  if(TIME){
    
    if(termR){
      
      RmatStandXmu <- RmatStandXse <- Rmat*0
      rhoMu <- rhoSe <- rhoTable <- NULL
      loL <- loRmat[wL]
      hiL <- hiRmat[wL]
      
      tmp <- .chain2tab(lgibbs[drop = FALSE, burnin:ng,], 
                        snames[notOther], xlnames, sigfig = 4)
      rhoStandXmu <- tmp$mu
      rhoStandXse <- tmp$se
      rhoStandXTable <- data.frame( rownames(tmp$tab), tmp$tab[,1:4],
                                    stringsAsFactors = F)
      rlo <- loRmat[wL]
      rhi <- hiRmat[wL]
      
      rprior <- cbind(rlo, rhi)
      rownames(rprior) <- rownames(wL)
      colnames(rprior) <- c('priorLo','priorHi')
      
      rhoStandXTable <- cbind( rhoStandXTable[,1:5], 
                               rprior[ rownames(rhoStandXTable), ])
      
      
      rhoStandXTable[,1] <- .replaceString( rhoStandXTable[,1], '_', ', ')
      ss <- 'rho_{to, from}'
      colnames(rhoStandXTable)[1] <- ss
      rhoStandXTable <- rhoStandXTable[!rhoStandXmu == 0 & !rhoStandXse == 0, ]
      rownames(rhoStandXTable) <- NULL
      
      
      tmp <- .chain2tab(lgibbs[drop = FALSE, burnin:ng,], 
                               colnames(Rmat), rownames(Rmat), sigfig = 4)
      RmatStandXmu[ wL ] <- tmp$tab[,'Estimate']
      RmatStandXse[ wL ] <- tmp$tab[,'SE']
      
      if( ncol(xl) > 1 ){
        Rmu <- Rmat*0
        tmp <- .chain2tab(lgibbsUn[drop = FALSE, burnin:ng,], 
                                   snames[notOther], xlnames, sigfig = 4)
        rhoMu <- tmp$mu
        rhoSe <- tmp$se
        rhoTable <- data.frame( rownames(tmp$tab), tmp$tab[,1:4],
                                stringsAsFactors = F)
        rhoTable[,1] <- .replaceString( rhoTable[,1], '_', ', ')
        ss <- 'rho_{to, from}'
        colnames(rhoTable)[1] <- ss
        rownames(rhoTable) <- NULL
        rhoTable <- rhoTable[!rhoMu == 0 & !rhoSe == 0, ]
      }else{
        lgibbsUn <- lgibbs
        rhoMu <- rhoStandXmu
        rhoSe <- rhoStandXse
        rhoTable <- rhoStandXTable
      }
    }
    if(termA){
      
      ss <- matrix( as.numeric( columnSplit( colnames(alphaGibbs), '-' )), ncol = 2) 
      ss <- matrix( snames[aindex[,c('toW','fromW')]], ncol=2)
      st <- columnPaste( ss[,1], ss[,2], ', ' )
      
      
      tmp <- .chain2tab(alphaGibbs[drop = FALSE, burnin:ng,], 
                        ss[,1], ss[,2], sigfig = 4)
      alphaTable <- data.frame( st, tmp$tab[, 1:4],
                                stringsAsFactors = F )
      
      alo <- loAmat[wA]
      ahi <- hiAmat[wA]
      
      aprior <- cbind(alo, ahi)
      colnames(aprior) <- c('priorLo','priorHi')
      
      alphaTable <- cbind( alphaTable[,1:5], aprior)
      
      colnames(alphaTable)[1] <- 'alpha_{to, from}'
      
      loA <-  matrix(0,S,S)
      rownames(loA) <- colnames(loA) <- snames
      hiA <- alphaMu <- alphaSe <- loA
      
      tmp1 <- colMeans(alphaGibbs[burnin:ng,])    
      tmp2 <- apply(alphaGibbs[burnin:ng,],2,sd)
      alphaMu[ aindex[,c('toW','fromW')] ] <- tmp1
      alphaSe[ aindex[,c('toW','fromW')] ] <- tmp2
      loA[ aindex[,c('toW','fromW')] ] <- loAmat[wA]
      hiA[ aindex[,c('toW','fromW')] ] <- hiAmat[wA]
      
      Amu <- Ase <- Amat*0
      Amu[wA] <- tmp1
      Ase[wA] <- tmp2
    }
  }
  
  yMu <- ypred/ntot
  if('CA' %in% typeNames){
    ytmp <- yMu[,'CA' %in% typeNames]
    ytmp[ ytmp < 0 ] <- 0
    yMu[,'CA' %in% typeNames] <- ytmp
  }
  y22 <- ypred2/ntot - yMu^2
  y22[y22 < 0] <- 0
  ySd <- sqrt(y22)
  
  cMu <- cuts
  cSe <- numeric(0)
  
  ms <- sums2meanSd( wpred, wpred2, ntot )  
  wMu <- ms$mean
  wSd <- ms$sd
  
  if('OC' %in% typeNames){
    yMu[,ordCols] <- yMu[,ordCols] + ordMatShift
    wMu[,ordCols] <- wMu[,ordCols] + ordMatShift
  }
  
  meanDev <- sumDev/ntot
  
  if( termB ){
    beta <- betaStandXmu
    if( is.null(beta) )beta <- betaMu
    beta[ is.na(beta) ] <- 0  # if prior is set to zero
  }
  
  if(!TIME){
    
    muw <- x%*%beta[,notOther, drop=F]
    tmp <- .dMVN(wMu[,notOther], muw, sMean[notOther,notOther], log=T)
    pd  <- meanDev - 2*sum(tmp )
    DIC <- pd + meanDev
  }
  
  yscore <- colSums( .getScoreNorm(y[,notOther],yMu[,notOther],
                                   ySd[,notOther]^2),na.rm=T )  # gaussian w
  xscore <- xpredMu <- xpredSd <- NULL
  standX <- xmissMu <- xmissSe <- NULL
  
  if(RANDOM){
    ns <- 500
    simIndex <- sample(burnin:ng,ns,replace=T)
    tmp <- .expandSigmaChains(snames, alphaVarGibbs, otherpar, simIndex=simIndex,
                              sigErrGibbs, kgibbs, REDUCT=F, CHAINSONLY=F)
    alphaRandGroupVarMu <- tmp$sMu
    alphaRandGroupVarSe <- tmp$sSe
    
    ms <- sums2meanSd( alphaRanSums, alphaRanSums2, ntot )  
    alphaRandByGroup   <- ms$mean
    alphaRandByGroupSe <- ms$sd
  }
  
  if(PREDICTX){
    ms <- sums2meanSd( predx, predx2, ntot )  
    xpredMu <- ms$mean
    xpredSd <- ms$sd
    
    if(!TIME){
      xrow <- standRows
      xmu  <- standMatMu[,1]
      xsd  <- standMatSd[,1]
    }else{
      if(termB | termR){
        xrow <- numeric(0)
        if(termB){xrow <- standRows}
        if(termR){
          xrow <- c( xrow, standRowsL )
          ww   <- !duplicated(names(xrow))
          xrow <- names(xrow)[ww]
          
          xmu <- xsd <- numeric(0)
          
          if(termB){
            xmu  <- standMatMu[xrow,1]
            xsd  <- standMatSd[xrow,1]
          }
          if(termR){
            
            ww <- which(!rownames(standMatMuL) %in% names(xrow) )
            ww <- ww[ ww != 1 ]
            if(length(ww) > 0){
              xmu  <- c(xmu, standMatMuL[ww,1])
              xsd  <- c(xsd,standMatSdL[ww,1])
            }
          }
        }
      }
    }
    
   # if( ncol(x) > 1 & !UNSTAND ){
      
    if( ncol(x) > 1 ){  
      
   #   xf  <- NULL
   #   if(length(facNames) > 0){
   #     xf <- xdata[, facNames, drop=F]
   #   }
      
      xpredMu <- .getUnstandX(formula, xs = xpredMu, xdata, xrow )$xu
      xpredSd[,xrow] <- xpredSd[,xrow]*matrix( xsd[xrow], n, length(xrow), byrow=T ) 
    }
    if(Q == 2)xscore <- mean( .getScoreNorm(x[,2],
                                            xpredMu[,2],xpredSd[,2]^2) )
    if(Q > 2)xscore <- colMeans(.getScoreNorm(x[,-1],
                                              xpredMu[,-1],xpredSd[,-1]^2) )
    
    if(TIME){
      wz <- muw <- wMu
      wz[wz < 0] <- 0
      if(termB){
        muw <- x[,rownames(beta),drop=F]%*%beta[,notOther,drop=F]
      }
      if(termR){
        Vmat[tindex[,2],] <- wz[tindex[,2], 
                                gindex[,'colW']]*xl[tindex[,2], gindex[,'colX']]
        Vmat[timeZero,]   <- wz[timeZero, 
                                gindex[,'colW']]*xl[timeZero, gindex[,'colX']]
        Rmat[ gindex[,c('rowL','colW')] ] <- RmatStandXmu[ gindex[,c('rowG','colW')] ]
        muw <- muw + Vmat%*%Rmat[,notOther]
      }
      if(termA){
        Umat <- wz[,uindex[,1]]*wz[,uindex[,2]] 
        Amat[ wA ] <- alphaMu[ aindex[,c('toW','fromW')] ]
        
        muw <- muw + Umat%*%Amat[,notOther]
      }
    }
  }
  tmp <- .dMVN(wMu[,notOther],muw, sMean[notOther,notOther], log=T )
  pd  <- meanDev - 2*sum(tmp )
  DIC <- pd + meanDev
  
  if(termB){
    if(nmiss > 0){
      ms <- sums2meanSd( xmissSum, xmissSum2, ntot )  
      xmissMu <- ms$mean
      xmissSe <- ms$sd
    }
  }
  if(length(standRows) > 0){                #unstandardize
    standX <- cbind(standMatMu[,1],standMatSd[,1])
    colnames(standX) <- c('xmean','xsd')
    rownames(standX) <- rownames(standMatSd)
  }

  # betaSens, sigma and R
  
  ns <- 200
  simIndex <- sample(burnin:ng,ns,replace=T)
  tmp <- .expandSigmaChains(snames, sgibbs, otherpar, simIndex=simIndex,
                            sigErrGibbs, kgibbs, REDUCT, CHAINSONLY=F, verbose)
  corMu <- tmp$rMu; corSe <- tmp$rSe
  sigMu <- tmp$sMu; sigSe  <- tmp$sSe
  
  if( !TIME | (TIME & termB) ){
    ematrix  <- ess/ntot
    fmatrix  <- fmat/ntot
    
    ms <- sums2meanSd( esens1, esens2, ntot )  
    sensBeta   <- cbind( ms$mean, ms$sd )
    colnames(sensBeta) <- c('Estimate', 'SE')
    rownames(sensBeta) <- colnames(y)
  }
  
  if(termR){
    if(ncol(xl) > 1){
      ematrixL <- essL/ntot
      ms <- sums2meanSd( lsens1, lsens2, ntot )  
      sensRho   <- cbind( ms$mean, ms$sd )
      colnames(sensRho) <- c('Estimate', 'SE')
      rownames(sensRho) <- colnames(y)
    }
  }
  if(termA){
    ematrixA <- essA/ntot
    ms <- sums2meanSd( asens1, asens2, ntot )  
    sensAlpha  <- cbind( ms$mean, ms$sd )
    colnames(sensAlpha) <- c('Estimate', 'SE')
    rownames(sensAlpha) <- colnames(y)
  }
  
  tMu <- tSd <- tMuOrd <- btMu <- btSe <- stMu <- stSe <- numeric(0)
  
  if(TRAITS){
    
    ms  <- sums2meanSd( tpred, tpred2, ntot )  
    tMu <- ms$mean
    tSd <- ms$sd
    wo  <- which(traitTypes == 'OC')    #predict ordinal scores
    M   <- ncol(tMu)
    
    if(length(wo) > 0){
      tMuOrd <- tMu*0
      for(j in wo)tMuOrd[,j] <- round(tMu[,j],0) - 1
      tMuOrd <- tMuOrd[,wo]
    }
    
    tmp <- .chain2tab(bTraitGibbs[burnin:ng,], tnames, xnames)     # standardized
    betaTraitXMu <- tmp$mu
    betaTraitXTable <- tmp$tab
    
    tmp <- .chain2tab(bTraitUnstGibbs[burnin:ng,], tnames, xnames) #  unstandardized
    betaTrait      <- tmp$mu
    betaTraitTable <- tmp$tab
    
    
    tmp <- .chain2tab(mgibbs[burnin:ng,], tnames, tnames) 
    varTraitMu <- tmp$mu
    varTraitTable <- tmp$tab
    
    tmp <- .chain2tab(bTraitFacGibbs[burnin:ng,], tnames, rownames(tagg) )
    betaTraitXWmu <- tmp$mu
    betaTraitXWTable <- tmp$tab
  }
  
  if('OC' %in% typeNames){
    
    nk  <- length(ordCols)
    nc  <- ncut - 3
    
    os <- rep(ordShift,nc)
    
    cgibbs <- cgibbs + matrix(os,ng,length(os),byrow=T)
    
    tmp <- .chain2tab(cgibbs[burnin:ng,], cnames[-c(1,2,ncut)], snames[ordCols], sigfig = 4 )
    
   # tmp <- .processPars(cgibbs)$summary
    
  #  cMu <- matrix(tmp[,'estimate'],nk,nc)
  #  cSe <- matrix(tmp[,'se'],nk,ncut-3)
    cMu <- tmp$mu
    cSe <- tmp$se
    cMu <- cbind(ordShift,cMu)
    cSe <- cbind(0,cSe)
    colnames(cMu) <- colnames(cSe) <- cnames[-c(1,ncut)]
    rownames(cMu) <- rownames(cSe) <- snames[ordCols]
    breakMat[ordCols,c(2:(2+(ncol(cMu))-1))] <- cMu
  }
  
  if('PA' %in% typeNames){
    zMu <- yMu
    zSd <- ySd
  }
  
  if( termB ){
    varContribution <- signif(rbind(varTot, varMu, varExp, varRn, varMod), 3) 
    rownames(varContribution) <- c('total variance', 'mean fraction','R2',
                              'RE fraction', 'mean + RE fraction')
    if(!RANDOM)varContribution <- varContribution[1:3,]
  }else{
    varContribution <- signif(varTot, 3) 
    names(varContribution) <- c('total variance')
  }
  
  

  # outputs
  if(length(reductList) == 0)reductList <- list(N = 0, r = 0)
  reductList$otherpar <- otherpar
  
  modelList$effort    <- effort;      modelList$formula <- formula
  modelList$typeNames <- typeNames;    modelList$censor <- censor
  modelList$effort    <- effort; modelList$holdoutIndex <- holdoutIndex
  modelList$REDUCT    <- REDUCT;       modelList$TRAITS <- TRAITS
  modelList$ematAlpha <- ematAlpha; modelList$traitList <- traitList
  modelList$reductList <- reductList; modelList$ng <- ng
  modelList$burnin <- burnin
  
  inputs <- list(xdata = xdata, xStand = x, xUnstand = xUnstand, 
                 xnames = xnames, effMat = effMat,
                 y = y, notOther = notOther, other = other, breakMat = breakMat, 
                 classBySpec = classBySpec, RANDOM = RANDOM)
  missing <- list(xmiss = xmiss, xmissMu = xmissMu, xmissSe = xmissSe, 
                  ymiss = ymiss, ymissMu = ymissPred, ymissSe = ymissPred2)
  parameters <- list(corMu = corMu, corSe = corSe, 
                     sigMu = sigMu, sigSe = sigSe,
                     wMu = wMu, wSd = wSd)
  prediction <- list(presence = presence, xpredMu = xpredMu, xpredSd = xpredSd,
                     ypredMu = yMu, ypredSd = ySd, richness = richness)
  chains <- list(sgibbs = sgibbs) 
  fit <- list(DIC = DIC, yscore = yscore, xscore = xscore, rmspeAll = rmspeAll,
              rmspeBySpec = rmspeBySpec,
              fractionExplained = varContribution )
  
  parXS <- 'standardized for X'
  parXU <- 'unstandardized for X'
  parWS <- 'correlation scale for W'
  parWU <- 'variance scale for W'
  parXF <- 'centered factors'
  parSep <- ', '
  
  getDescription <- function( nlist, words ){
    
    out <- numeric(0)
    nm  <- character(0)
    
    for(k in 1:length(nlist)){
      vk <- get( nlist[k] ) 
      if( is.null(vk) )next
      attr( vk, 'description') <- words 
      out <- append( out, list(assign( nlist[k], vk )) )
      nm  <- c( nm, nlist[k])
    }
    names(out) <- nm
  
    out
  }
  
  
  
  if( !TIME | (TIME & termB) ){
    
    if( all(diag(ematrix) == 0) )ematrix <- NULL
    
    nlist <- c( 'ematrix', 'fmatrix' )
    words <- paste( parXS, parWS, parXF, sep=parSep)
    tlist <- getDescription( nlist, words )
    if(length(tlist) > 0){
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
    }    
    parameters <- c(parameters, list(ematrix = ematrix, fmatrix = fmatrix, 
                                     sensBeta = sensBeta))
  }
  
  if(termB){
    
    nlist <- c('betaMu', 'betaSe', 'betaTable', 'bgibbsUn' )
    words <- paste( parXU, parWU, sep=parSep)
    tlist <- getDescription( nlist, words )
    if(length(tlist) > 0){
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
    }    
    
    nlist <- c('betaStandXmu', 'betaStandXTable', 'bgibbs')
    words <- paste( parXU, parWU, sep=parSep )
    tlist <- getDescription( nlist, words )
    if(length(tlist) > 0){
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
    }
    
    nlist <- c( 'betaStandXWmu', 'betaStandXWTable' )
    if(!is.null(sensTable))nlist  <- c(nlist, 'sensTable')
    if(!is.null(fSensGibbs))nlist <- c(nlist, 'fSensGibbs')
    if(!is.null(bFacGibbs))nlist  <- c(nlist, 'bFacGibbs')
    
    
    words <- paste( parXS, parWS, parXF, sep = parSep)
    tlist <- getDescription( nlist, words )
    
    if(length(tlist) > 0){
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
    }
    
    attr(sensBeta, 'description') <- parXS
    
    inputs <- c(inputs, list(standMatSd = standMatSd, standRows = standRows, standX = standX,
                             notOther = notOther, other = other,  designTable = designTable,  
                             factorBeta = factorBeta, interBeta = interBeta,
                             linFactor = linFactor, intMat = intMat) )
    chains <- c(chains, list(bgibbs = bgibbs, bgibbsUn = bgibbsUn,
                             fSensGibbs = fSensGibbs, bFacGibbs = bFacGibbs) )
    parameters <- c(parameters, list(betaMu = betaMu, betaSe = betaSe, betaTable = betaTable, 
                                     betaStandXmu = betaStandXmu, 
                                     betaStandXTable = betaStandXTable,
                                     betaStandXWmu =  betaStandXWmu,
                                     betaStandXWTable = betaStandXWTable,
                                     sensTable = sensTable))
  }
  
  if(FULL)chains <- append(chains, list(ygibbs = ygibbs))
  if(RANDOM){
    parameters <- append(parameters,
                         list( randGroupVarMu = alphaRandGroupVarMu,
                               randGroupVarSe = alphaRandGroupVarSe,
                               randByGroupMu = alphaRandByGroup,
                               randByGroupSe = alphaRandByGroupSe,
                               groupIndex = groupIndex) )
  }
  if(RICHNESS){
    prediction <- append(prediction, 
                         list(yPresentMu = ypredPresMu, yPresentSe = ypredPresSe))
  }
  if(REDUCT) {
    ms  <- sums2meanSd( rndTot, rndTot2, ntot )  
    rndEffMu <- ms$mean
    rndEffSe <- ms$sd
    parameters <- append( parameters, list(rndEffMu = rndEffMu, rndEffSe = rndEffSe) )
    chains <- append( chains, list(kgibbs = kgibbs, sigErrGibbs = sigErrGibbs) )
  }

  if('OC' %in% typeNames){
    parameters <- c(parameters,list(cutMu = cMu, cutSe = cSe))
    chains <- c(chains,list(cgibbs = cgibbs))
    modelList <- c(modelList,list(yordNames = yordNames))
  }
  
  if(TRAITS){
    parameters <- c(parameters,
                    list(betaTrait = betaTrait, 
                         betaTraitTable = betaTraitTable,
                         betaTraitXMu = betaTraitXMu, 
                         betaTraitXTable = betaTraitXTable,
                         varTraitMu = varTraitMu, 
                         varTraitTable = varTraitTable,
                         betaTraitXWmu = betaTraitXWmu,
                         betaTraitXWTable = betaTraitXWTable))
    prediction <- c(prediction, list(tMuOrd = tMuOrd, tMu = tMu, tSe = tSd))
    chains <- append( chains,list(bTraitGibbs = bTraitGibbs,
                                  bTraitFacGibbs = bTraitFacGibbs,
                                  mgibbs = mgibbs) ) 
  }
  
  if(TIME){
    
    inputs <- c(inputs, list(timeList = timeList))
    
    if(termB){
      parameters <- c(parameters, list(wB = wB, tindex = tindex))
    }
    if(termR){
      
      nlist <- c('lgibbs', 'rhoStandXmu', 'rhoStandXse', 'rhoStandXTable')
      tlist <- getDescription( nlist, words = parXS )
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
      
      nlist <- c('lgibbsUn', 'rhoMu', 'rhoSe', 'rhoTable')
      tlist <- getDescription( nlist, words = parXU )
      for( k in 1:length(tlist) ) assign( names(tlist)[k], get( names(tlist[k]) ) )
      
      inputs <- c(inputs, list(xlnames = xlnames, xRho = xl, interRho = interRho, 
                               factorRho = factorRho))
      chains <- c(chains, list(lgibbs = lgibbs, lgibbsUn = lgibbsUn))
      parameters <- c(parameters, 
                      list(gindex = gindex, rhoMu = rhoMu, rhoSe = rhoSe,
                           rhoStandXmu = rhoStandXmu, rhoStandXse = rhoStandXse, 
                           rhoTable = rhoTable,
                           rhoStandXTable = rhoStandXTable,  
                           RmatStandXmu = RmatStandXmu, RmatStandXse = RmatStandXse,
                           rhoLo = loL, rhoHi = hiL, wL = wL))
      
      if( ncol(xl) > 1 ){
        attr(ematrixL, 'description') <- attr(sensRho, 'description') <- parXS
        parameters <- c(parameters, 
                        list(ematrixL = ematrixL, sensRho = sensRho))
      }
    }
    if(termA){
      
      chains <- c(chains, list(alphaGibbs = alphaGibbs))
      parameters <- c(parameters, list(alphaTable = alphaTable,
                                       alphaMu = signif(alphaMu, 4), 
                                       alphaSe = signif(alphaSe, 4),
                                       Amu = signif(Amu, 4), 
                                       Ase = signif(Ase, 4),
                                       alphaLo = loA, alphaHi = hiA,
                                       aindex = aindex, wA = wA, uindex = uindex,
                                       ematrixA = ematrixA, sensAlpha = sensAlpha,
                                       alphaEigen = eigen(alphaMu)$values))
    }
  }
  
  chains     <- chains[ sort( names(chains) ) ]
  fit        <- fit[ sort( names(fit) )]
  inputs     <- inputs[ sort( names(inputs) )]
  missing    <- missing[ sort( names(missing) )]
  modelList  <- modelList[ sort( names(modelList) )]
  parameters <- parameters[ sort( names(parameters) )]
  prediction <- prediction[ sort( names(prediction) )]
  
  wk <- sapply( chains, length )
  chains <- chains[ wk > 0 ]
  
  wk <- sapply( fit, length )
  fit <- fit[ wk > 0 ]
  
  wk <- sapply( inputs, length )
  inputs <- inputs[ wk > 0 ]
  
  wk <- sapply( missing, length )
  missing <- missing[ wk > 0 ]
  
  wk <- sapply( modelList, length )
  modelList <- modelList[ wk > 0 ]
  
  wk <- sapply( parameters, length )
  parameters <- parameters[ wk > 0 ]
  
  wk <- sapply( prediction, length )
  prediction <- prediction[ wk > 0 ]
  
  
  all <- list(chains = chains, fit = fit, inputs = inputs, missing = missing,
              modelList = modelList, parameters = parameters,
              prediction = prediction)
  all$call <- match.call()
  all <- all[ sort(names(all)) ]
  class(all) <- "gjam"
  
  all
}

designFull <- function( form, xdata ){
  
  n   <- nrow(xdata)
  tmp <- model.frame( form, xdata)
  terms <- attributes( tmp )$terms
  xnames <- attr( terms, 'term.labels' )
  facts <- which( attr( terms,'dataClasses' ) == 'factor' )
  ints  <- grep(':', xnames)
  
  xfull <- numeric(0)
  # main effects
  for(k in 1:ncol(tmp)){
    if( !k %in% facts){
      x <- matrix( tmp[,k], ncol = 1)
      colnames(x) <- colnames(tmp)[k]
      xfull <- cbind(xfull, x)
      next
    }
    levs <- levels(tmp[,k])
    xk <- matrix(0, n, length(levs))
    colnames(xk) <- paste(names(facts)[k], levs, sep='')
    mm <- match( as.character(tmp[,k]), levs )
    xk[ cbind(1:n, mm) ] <- 1
    xfull <- cbind(xfull, xk)
  }
  csum <- colSums(abs(xfull), na.rm=T)
  xfull <- xfull[,csum > 0]
  
  if(length(ints) > 0){   # there are interactions 
    interactions <- numeric(0)
    for(k in ints){
      xi <- columnSplit( xnames[k], ':' )
      x1 <- which( startsWith(colnames(xfull), xi[1] ) )
      x2 <- which( startsWith(colnames(xfull), xi[2] ) )
      cnames <- outer( colnames(xfull)[x1], colnames(xfull)[x2], paste, sep=':'  )
      xint <- matrix(0, n, length(cnames))
      colnames(xint) <- cnames
      for(i in x1){
        for(j in x2){
          ij <- paste( colnames(xfull)[i], colnames(xfull)[j], sep=':')
          xint[,ij] <- xfull[,i] * xfull[,j]
        }
      }
      interactions <- cbind(interactions, xint)
    }
    xfull <- cbind(xfull, interactions)
  }
  csum <- colSums(abs(xfull), na.rm=T)
  xfull <- xfull[,csum > 0]

  # cannot be transformed, not full rank
}
   
.contrastCoeff <- function(beta, sigma, sinv, notStand, stand, factorObject,
                           conditional=NULL){ 
  SO  <- ncol(beta)
  agg <- .sqrtMatrix(beta,sigma,DIVIDE=T)  #cor/stand scale
  
  if(factorObject$nfact > 0){          # center factors
    agg <- factorObject$lCont%*%agg    # standardized x, cor scale for w
    for(k in 1:factorObject$nfact){
      f2  <- factorObject$facList2[[k]]
      fk  <- paste(names(factorObject$facList2)[k],f2,sep='')
 
      amu <- colMeans(agg[drop=F,fk,])
      nl  <- length(fk)
      agg[fk,] <- agg[fk,] - matrix(amu,nl,SO,byrow=T)
      egg <- agg
    }
  } else {
    agg <- agg[drop=F,-1,]
    egg <- agg
  }
  if(is.null(conditional)){
    
    sens <- egg%*%sinv%*%t(egg)
    
  }else{
    con <- which(colnames(beta) %in% conditional)
    if( length(con) == 0 )stop( 'group must be in colnames(ydata)' )
    nc  <- c(1:SO)[-con]
    sg  <- sigma[con,con] - 
           sigma[con,nc]%*%solveRcpp(sigma[nc,nc])%*%sigma[nc,con]
    sens <- egg[,con]%*%solveRcpp(sg)%*%t(egg[,con])
  }
    
  list(ag = agg, eg = egg, sens = sens)
}

.chain2tab <- function(chain, snames = NULL, xnn = NULL, wF = NULL, sigfig = 3){
  
  mu <- colMeans(chain)  
  SE <- apply(chain,2,sd)
  CI <- apply(chain,2,quantile,c(.025,.975))
  splus <- rep('', length=length(SE))
  splus[CI[1,] > 0 | CI[2,] < 0] <- '*'
  
  tab <- cbind( mu, SE, t(CI))
  tab <- signif(tab, sigfig)
  colnames(tab) <- c('Estimate','SE','CI_025','CI_975')
  tab <- as.data.frame(tab)
  tab$sig95 <- splus
  attr(tab, 'note') <- '* indicates that zero is outside the 95% CI'
  
  mmat <- smat <- NULL
  
  if(!is.null(snames)){
    
    Q <- length(xnn)
    S <- length(snames)
    
    mmat <- matrix(NA, Q, S)
    colnames(mmat) <- snames
    rownames(mmat) <- xnn 
    smat <- mmat
    
    if(is.null(wF)){
      wF <- 1:length(mmat)
    }
    
    mmat[ wF ] <- signif(mu, sigfig)
    smat[ wF ] <- signif(SE, sigfig)
    
    ww <- which(rowSums(mmat, na.rm=T) != 0)
    mmat <- mmat[drop = FALSE, ww,]
    smat <- smat[drop = FALSE, ww,]
  }
  
  list(mu = mmat, se = smat, tab = tab)
}

summary.gjam <- function(object,...){ 
  
  TRAITS <- F
  bb <- sens <- NULL
  
  termB <- termR <- termA <- F
  
  if('betaMu' %in% names(object$parameters)){
    termB <- T
    beta   <- object$parameters$betaMu # not standardized
  }
  n  <- nrow(object$inputs$y)
  S  <- ncol(object$inputs$y)
  Q  <- ncol(object$inputs$xStand)
  notOther <- object$inputs$notOther
  other    <- object$inputs$other
  
  ng <- object$modelList$ng
  burnin <- object$modelList$burnin
  
  if("betaTraitTable" %in% names(object$parameters))TRAITS <- T

  if('fSensGibbs' %in% names(object$chains)){
    sens <- .chain2tab(object$chains$fSensGibbs[burnin:ng,])$tab[,1:4]
    toConsole( 'Sensitivity by predictor variables f', sens )
  }
  
  RMSPE       <- object$fit$rmspeBySpec
  imputed <- rep(0,S)
  missingx <- rep(0,Q)
  if(length(object$missing$xmiss) > 0){
    xtab <- table(object$missing$xmiss[,2])
    missingx[ as.numeric(names(xtab)) ] <- xtab
  }
  if(length(object$missing$ymiss) > 0){
    xtab <- table(object$missing$ymiss[,2])
    imputed[ as.numeric(names(xtab)) ] <- xtab
  }
  
  if(termB){
    RMSPE <- RMSPE[notOther]
    bb   <- t( signif(rbind(beta[,notOther,drop=F], RMSPE),3) )
    toConsole( 'Coefficient matrix B', t(bb) )
    toConsole( 'Coefficient matrix B as table')
    toConsole( 'Last column indicates if 95% posterior distribution contains zero', 
               object$parameters$betaTable )
   
    if( !is.null(object$parameters$betaStandXtable) ){
      toConsole( 'Coefficient matrix B, standardized for X' )
      toConsole( 'Last column indicates if 95% posterior distribution contains zero', 
                 object$parameters$betaStandXtable )
    }
    
    if( !is.null(object$parameters$betaStandXWtable) ){
      toConsole( 'Coefficient matrix B, standardized for X and W' )
      toConsole( 'Last column indicates if 95% posterior distribution contains zero',  
                 object$parameters$betaStandXWtable)
    }
    toConsole( 'Variance contributions from model mean and random effects', 
               object$fit$fractionExplained )
  }
  
  
  if(TRAITS){
    toConsole( 'Coefficient matrix for traits' )
    toConsole( 'Last column indicates if 95% posterior distribution contains zero', 
               object$parameters$betaTraitTable )
    toConsole( 'oefficient matrix for traits, standardized for X and W', 
               object$parameters$betaTraitXWTable )
  }
  
  if( length(object$modelSummary$missFacSpec) > 0 ){
    toConsole( 'Missing factor combinations' , object$modelSummary$missFacSpec)
  }
  
  dt <- object$inputs$designTable
  if(!is.null(dt)){
    toConsole( 'Design Table: VIF and correlations' , dt)
  }
  
  words <- .summaryWords(object)
  cat("\n",words)
    
  res <- list(DIC=object$fit$DIC)
  if(!is.null(sens))res$sensitivity <- sens
  if(!is.null(bb))res$Coefficients <- bb
  
  class(res) <- "summary.gjam"
  invisible(res) 
}

.summaryWords <- function(object){
  
  Q  <- ncol(object$inputs$xStand)
  n  <- nrow(object$inputs$y)
  S  <- ncol(object$inputs$y)
  other    <- object$inputs$other
  notOther <- object$inputs$notOther
  
  nxmiss <- nrow( object$missing$xmiss )
  nymiss <- nrow( object$missing$ymiss )
  nholdout <- length(object$modelList$holdoutIndex)
  types    <- unique(object$modelList$typeNames)
  if(length(types) == 1)types <- rep(types,S)
  
  ef <- ""
  if( 'DA' %in% types ){
    wd  <- which(types == 'DA')
    rf  <- object$modelList$effort$values[,wd]
    gf <- signif( range(rf), 2)
    wr  <- signif( range(object$inputs$y[,wd]/rf), 3)
    if(gf[1] == gf[2]){
      ab <- paste(" DA effort is ",gf[1]," for all observations. ",sep="")
    }else{
      ab <- paste(" DA effort ranges from ", gf[1], " to ", gf[2],".",sep="")
    }
    ef <- paste(ab, " DA counts per effort (W) ranges from ", 
                wr[1], " to ", wr[2], ".",sep="")
  }
  if( 'CC' %in% types ){
    wd  <- which(types == 'CC')
    rr  <- round( range(object$inputs$y[,wd]) )
    ef <- paste(ef, " CC count range is (", rr[1],", ", rr[2], ").", sep="")
  }
  oc <- ""
  if(length(other) > 0){
    oc <- paste(" 'other' class detected in ydata, '", 
                colnames(object$inputs$y)[other], " column ",
                "', not fitted. ",sep='')
  }
  
  ty <- paste0( unique(types), collapse=", ")
  
  words <- paste("The sample contains n = ", n, " observations on S = ",
                 S, " response variables.  Data types (typeNames) include ", ty,
                 ".", ef, oc, " There are ", nxmiss, 
                 " missing values in X and ", nymiss, 
                 " missing values in Y. The RMSPE is ",
                 signif(object$fit$rmspeAll,3),
                 ", and the DIC is ",round(object$fit$DIC),".", sep="")
  dr <- ""
  if(object$modelList$REDUCT){
    nr <- object$chains$kgibbs
    nd <- t( apply(nr,1,duplicated) )
    nr[!nd] <- 0
    nr[nr > 0] <- 1
    nk <- rowSums(1 - nr)
    nk <- max(nk[object$modelList$burnin:object$modelList$ng])
    
    dr <- paste("  Dimension reduction was implemented with N = ",nk,
                " and r = ",object$modelList$reductList$r,".",
                sep="")
  }
  ho <- ""
  if(nholdout > 0)ho <- paste(" Held out were",nholdout,"observations.")
  comp <- paste(" Computation involved ", object$modelList$ng,
                " Gibbs steps, with a burnin of ", object$modelList$burnin, 
                ".",dr,ho,sep='')
  paste(words, comp)
}

print.gjam <- function(x, ...){
  
  summary.gjam(x)
}

.getSigTable <- function(chain, SS, QQ, xn, sn){
  
  bci  <- apply(chain,2,quantile,c(.025,.975))
  tmp  <- .between(rep(0,SS*QQ),bci[1,],bci[2,],OUT=T)
  ii <- rep(' ',SS*QQ)
  ii[tmp[bci[1,tmp] < 0]] <- '-'
  ii[tmp[bci[2,tmp] > 0]] <- '+'
  
  bTab <- data.frame( matrix(ii,QQ,SS) )
  colnames(bTab) <- sn
  rownames(bTab) <- xn
  
  data.frame( t(bTab) )
}

.getPlotLayout <- function(np){
  
  # np - no. plots
  
  if(np == 1)return( c(1,1) )
  if(np == 2)return( c(1,2) )
  if(np == 3)return( c(1,3) )
  if(np <= 4)return( c(2,2) )
  if(np <= 6)return( c(2,3) )
  if(np <= 9)return( c(3,3) )
  if(np <= 12)return( c(3,4) )
  if(np <= 16)return( c(4,4) )
  if(np <= 20)return( c(4,5) )
  if(np <= 25)return( c(5,5) )
  if(np <= 25)return( c(5,6) )
  return( c(6,6) )
}

sqrtSeq <- function( xx, nbin = 15){ #labels for sqrt scale
  
  # xx on sqrt scale
  
  maxval <- max(xx, na.rm = T)
  minval <- min(xx, na.rm = T)
  
  by <- 2
  if(maxval >= 5)   by <- 10 
  if(maxval >= 10)  by <- 20 
  if(maxval >= 20)  by <- 100 
  if(maxval >= 30)  by <- 200 
  if(maxval >= 50)  by <- 500
  if(maxval >= 70)  by <- 1000
  if(maxval >= 100) by <- 2000
  if(maxval >= 200) by <- 10000
  if(maxval >= 500) by <- 50000
  if(maxval >= 700) by <- 100000
  if(maxval >= 1000)by <- 200000
  if(maxval >= 1500)by <- 400000
  
  labs <- seq(0, maxval^2, by = by)
  
  while(length(labs) < nbin){
    
    labs <- seq(minval^2, maxval^2, by = by)
    by <- by/2
    
  }
  while(length(labs) > (nbin + 2)){
    
    labs <- seq(minval^2, maxval^2, by = by)
    by <- 1.2*by
  }
  at   <- sqrt(labs)
  labs <- signif(labs, 2)
  
  list(at = at, labs = labs)
}

.plotObsPred <- function(xx, yy, opt = NULL, col='darkgreen', points = F, add = F){
  
  atx <- aty <- breaks <- NULL 
  
  xlabel <- 'Observed'
  ylabel <- 'Predicted'
  trans  <- .8 
  xlimit <- range(xx, na.rm=T)
  ylimit <- range(yy, na.rm=T)
  
  if(!is.null(opt))for(k in 1:length(opt))assign( names(opt)[k], opt[[k]] )
  
  if( is.na(col) )col <- 'darkgreen'
  
  ww <- which(is.finite(xx) & is.finite(yy))
  xx <- xx[ww]
  yy <- yy[ww]
  
  if( !add ){
    if( !points ){
      plot(NA, xlim = xlimit, xlab = xlabel, ylab = ylabel, ylim = ylimit)
    }else{
    plot(xx, yy, col = .getColor( col, trans), cex = .3,
         xlim = xlimit, xlab = xlabel, ylab = ylabel, ylim = ylimit,
         xaxt = 'n',yaxt = 'n')
    }
  }
  
  if( is.null(atx) )atx <- breaks
  
  if( is.null(atx) ){
    tmp <- .bins4data( xx )
    atx <- breaks  <- tmp$bins
  }
  
  bins <- atx
 # bin1 <- 1
  
  if( length(atx) < 8 )bins <- breaks <- .bins4data( xx )$bins
  nbin <- length(bins)
 # sbin <- length(bins)
  
  xb <- findInterval(xx, bins, all.inside = TRUE)
  tt <- table(xb)
  kbin <- as.numeric(names(tt))
 # bins <- bins[ as.numeric(names(tt)) ]
 # xb <- findInterval(xx, bins, all.inside = TRUE)
 # nbin <- length(bins)
  xf   <- (tt/sum(tt))^.5
  xf[ xf < .002 ] <- .002
  xs   <- xf^.2
  
  wide <- diff(bins)/2
  wide[ wide > 2*min(wide) ] <- 2*min(wide)
  wide <- c( wide, wide[ length(wide) ] )
  db   <- 1
  
  for(k in kbin){
    
    qk <- which(xb == k)
    q  <- quantile(yy[qk],c(.5,.025,.158,.841,.975),na.rm=T)
    
    if(!is.finite(q[1]))next
    if(q[2] == q[5])next
    
    if(k > 1)db <- bins[k] - bins[k-1]
    
    if(k < nbin){
      if(bins[k] > 0 & bins[k+1] > 0){
        xp <- sqrt( bins[k]*bins[k+1] )
      }else{
        xp <- mean( bins[k:(k+1)] )
      }
    }else{
      xp <- bins[k] + db/2
    }
    rwide <- wide[k]
    
    xtrans <- xs[ as.character(k) ]
    ftrans <- xf[ as.character(k) ]
    
    errorBars( xp, q[2], q[5], code=3, col=.getColor(col,xtrans), length=.02)
    lines(c(xp-.5*rwide,xp+.5*rwide),q[c(1,1)],lwd=2, 
          col=.getColor(col,sqrt(ftrans)))
    rect(xp-.4*rwide,q[3],xp+.4*rwide,q[4], border = .getColor(col,xtrans), 
                                                               col=.getColor(col,ftrans))
  }
}

sqrtSeq <- function(maxval, nbin = 10){ #labels for sqrt scale
  
  # maxval on sqrt scale
  
  by   <- signif(maxval^1.7, 1)
  labs <- seq(0, maxval^2, by = by)
  
  while(length(labs) < nbin){
    by <- .5*by
    labs <- seq(0, maxval^2, by = by)
  }
    
  at   <- sqrt(labs)
  labs <- signif(labs, 2)
  ww   <- which(!duplicated(labs))
  labs <- labs[ww]
  at   <- at[ww]
  
  list(at = at, labs = labs)
}

.getBinSqrt <- function(xx, yy, nbin = 10 ){
  
  yy[ yy < 0 ] <- 0
  
  sxx <- suppressWarnings( sqrt(xx) )
  syy <- suppressWarnings( sqrt(yy) )
  
  # equal intervals on sqrt scale
  tx <- sqrtSeq( maxval = max(sxx, na.rm=T), nbin )
  ty <- sqrtSeq( maxval = max(syy, na.rm=T), nbin )
  
  xtick <- tx$at
  xlab  <- tx$labs
  
  sig <- round( quantile(log10(xlab),.7) )
  
  labx  <- round(xlab, -sig + 1)
  wd    <- which( !duplicated(labx) )
  if( length(wd) < nbin ){
    labx  <- round(xlab, -sig + 2)
    wd    <- which( !duplicated(labx) )
  }
  xlab  <- labx[wd]
  xtick <- xtick[ wd ]
  
  sig <- round( quantile(log10(ty$labs),.7) )
  laby  <- round(ty$labs, -sig + 1)
  wd    <- which( !duplicated(laby) )
  ylab  <- laby[wd]
  ytick <- ty$at[ wd ]
  
  
  if(length(xtick) == 1)xtick <- range(xtick)
  
  list(xlim = range(tx$at, na.rm=T), ylim = range(ty$at, na.rm=T), 
       atx = xtick, labx = xlab, xtick = xtick, 
       aty = ytick, laby = ylab)
}

.shadeInterval <- function(xvalues,loHi,col='grey',PLOT  = TRUE, add  = TRUE,
                           xlab=' ',ylab=' ', xlim = NULL, ylim = NULL, 
                           LOG = FALSE, trans = .5){
  
  tmp <- smooth.na(xvalues,loHi)
  
  xvalues <- tmp[,1]
  loHi <- tmp[,-1]
  
  xbound <- c(xvalues,rev(xvalues))
  ybound <- c(loHi[,1],rev(loHi[,2]))
  if(is.null(ylim))ylim <- range(as.numeric(loHi))
  if(is.null(xlim))xlim <- range(xvalues)
  
  if(!add){
    if(!LOG)plot(NULL, xlim = xlim, ylim=ylim, 
                 xlab=xlab, ylab=ylab)
    if(LOG)suppressWarnings( plot(NULL,  xlim = xlim, ylim=ylim, 
                                  xlab=xlab, ylab=ylab, log='y') )
  }
  if(PLOT)polygon(xbound,ybound, border=NA,col=.getColor(col, trans))
  
  invisible(cbind(xbound,ybound))
  
}

smooth.na <- function(x,y){   
  
  #remove missing values
  #x is the index
  #y is a matrix with rows indexed by x
  
  if(!is.matrix(y))y <- matrix(y,ncol=1)
  
  wy <- which(!is.finite(y),arr.ind   = TRUE)
  if(length(wy) == 0)return(cbind(x,y))
  wy <- unique(wy[,1])
  ynew <- y[-wy,]
  xnew <- x[-wy]
  
  cbind(xnew,ynew)
}

.getBin <- function(xx, yy, minbin = 5, length = 15){
  
  # aggregates feathery tails of distribution
  
  xi  <- xr  <- seq(min(xx, na.rm=T), max(xx, na.rm=T), length = length)
  xc  <- findInterval(xx, xi, all.inside = T)
  tab <- table(xc)
  
  while( tab[1] < (minbin/2) ){
    xi <- xi[-1]
    xc  <- findInterval(xx, xi, all.inside = T)
    tab <- table(xc)
  }
  nt <- length(tab)
  nx <- length(xi)
  while( tab[nt] < (minbin/2) ){
    xi <- xi[-nx]
    xc  <- findInterval(xx, xi, all.inside = T)
    tab <- table(xc)
    nx <- length(xi)
    nt <- length(tab)
  }
  
  # interior
  while(min(tab) < minbin){
    length <- length - 1
    xi  <- seq(min(xi, na.rm=T), max(xi, na.rm=T), length = length)
    xc  <- findInterval(xx, xi, all.inside = T)
    tab <- table(xc)
    nx <- length(xi)
    nt <- length(tab)
  }
  xi[1]  <- xr[1]
  xi[nx] <- xr[length(xr)]
  
  xmids <- (xi[1:(nx-1)] + xi[2:nx])/2
  
  list(xseq = xi, xmids = xmids, xbin = xc)
}


rmOther <- function( x ){
  
  wo <- grep('other', colnames(x))
  if(length(wo) > 0)x   <- x[,-wo]
  wo <- grep('other', rownames(x))
  if(length(wo) > 0)x   <- x[-wo,]
  x
}


.gjamPlot <- function(output, plotPars, verbose = FALSE){
  
  FACNAMES <- TRUE              # if not, factor names omitted from plots
  PLOTALLY <- TRAITS <- GRIDPLOTS <- SAVEPLOTS <- 
    REDUCT <- TV <- SPECLABS <- SMALLPLOTS <- F
  PREDICTX <- BETAGRID <- PLOTY <- PLOTX <- 
    CORLINES <- SIGONLY <- CHAINS <- RANDOM <- T
  omitSpec   <- trueValues  <- censor <- otherpar <- ng <- NULL
  traitList  <- specByTrait <- typeNames <- classBySpec <- 
    x <- y   <- burnin      <- richness <- betaTraitMu <-  
    corSpec  <- cutMu       <- ypredMu <- DIC <- yscore <- missingIndex <- 
    xpredMu  <- plotByTrait <- tMu <- tMuOrd <- traitTypes <- 
    isFactor <- betaMu <- betaMuUn <- corMu <- modelSummary <-
    randByGroup <- randGroupVarMu <- NULL
  unstandardX  <- NULL 
  specColor    <- NULL
  ematAlpha    <- alphaEigen <- .5  
  ematrix      <- ematrixL <- ematrixA <- eComs <- NULL
  ymiss <- eCont <- modelList <- timeList <- timeZero <- NULL
  random <- NULL
  kgibbs <- NULL
  chains <- inputs <- parameters <- prediction <- reductList  <- 
    bgibbs <- sgibbs <- sigErrGibbs <- factorBeta <- gsens <- 
    bFacGibbs <- alphaGibbs <- times <- alphaMu <- rhoMu <-  
    factorBetaList <- factorRho <- rhoMuUn <- notOther <- other <- NULL
  
  xStand <- wL <- wA <- xUnstand <- sensAlpha <- sensRho <- 
    sensBeta <- rhoStandXmu <- evecs <- NULL
  
  holdoutN <- 0
  
  TIME <- termB <- termR <- termA <- FALSE

  cex <- 1
  holdoutIndex <- numeric(0)
  clusterIndex <- clusterOrder <- numeric(0)
  xlnames <- character(0)
  
  ncluster   <- min(c(4,ncol(y)))

  outFolder <- 'gjamOutput'
  outfile   <- character(0)

  width <- height <- 3

  oma <- c(1,1,0,0)
  mar <- c(1,1,1,0)
  tcl <- -0.1
  mgp <- c(0,0,0)

  traitColor <- textCol <- 'black'
    
  for(k in 1:length(output))assign( names(output)[k], output[[k]] )
  for(k in 1:length(chains))assign( names(chains)[k], chains[[k]] )
  for(k in 1:length(fit))assign( names(fit)[k], fit[[k]] )
  for(k in 1:length(inputs))assign( names(inputs)[k], inputs[[k]] )
  for(k in 1:length(missing))assign( names(missing)[k], missing[[k]] )
  for(k in 1:length(modelList))assign( names(modelList)[k], modelList[[k]] )
  
  colnames( parameters$corMu ) <- rownames( parameters$corMu ) <- rownames( parameters$sigMu )
  colnames( parameters$corSe ) <- rownames( parameters$corSe ) <- rownames( parameters$corSe )
  
  for(k in 1:length(parameters)){
    pk <- rmOther( parameters[[k]] ) 
    assign( names(parameters)[k], pk )
  }
  for(k in 1:length(prediction))assign( names(prediction)[k], prediction[[k]] )
  for(k in 1:length(reductList))assign( names(reductList)[k], reductList[[k]] )
  
  if('bgibbs' %in% names(chains))    termB <- TRUE
  if('lgibbs'  %in% names(chains))   termR <- TRUE
  if('alphaGibbs' %in% names(chains))termA <- TRUE
  
  x <- xStand
  rm(xStand)
  
  if(!is.null(plotPars))for(k in 1:length(plotPars))assign( names(plotPars)[k], plotPars[[k]] )
  
  # 'other' response is not fitted
  xnames <- colnames(x)
  snames <- colnames(y)
  names(typeNames) <- snames

  if( !is.null(traitList) ){
    TRAITS <- T
    for(k in 1:length(traitList))assign( names(traitList)[k], traitList[[k]] )
  }
  
  if( 'trueValues' %in% names(plotPars) ){
    
    TV <- T
    for(k in 1:length(trueValues)){
      trueValues[[k]] <- rmOther( trueValues[[k]] )
      assign( names(trueValues)[k], trueValues[[k]] )
    }
    
    if(termB){
      beta      <- beta[,colnames(betaMu)]
    }
    if(termR){
      rho    <- rhoMu
    }
    if('sigma' %in% names(trueValues)){
      sigma     <- sigma[colnames(corMu),colnames(corMu)]
    }
    if('corSpec' %in% names(trueValues)){
      corSpec   <- corSpec[colnames(corMu),colnames(corMu)]
    }
  }
  if(!is.null(timeList)){
    for(k in 1:length(timeList))assign( names(timeList)[k], timeList[[k]] )
    ypredMu[timeZero,] <- NA
    TIME <- T
  }
  if(length(xpredMu) == 0)PREDICTX <- F
  if(!PREDICTX)PLOTX <- F
  
  if(!is.null(random))RANDOM <- T
  
  oma <- c(0,0,0,0)
  mar <- c(4,4,2,1)
  tcl <- -0.5
  mgp <- c(3,1,0)
  
  if(SAVEPLOTS){
    ff <- file.exists(outFolder)
    if(!ff)dir.create(outFolder)
  }
  
  chainNames <- names(chains)
  allTypes   <- unique(typeNames)
  
  ntypes   <- length(allTypes)
  typeCode <- match(typeNames,allTypes)
  specs    <- rownames(classBySpec)
  Q        <- ncol(x)
  nhold    <- length(holdoutIndex)
  ncut     <- ncol(classBySpec) + 1
  S        <- ncol(y)
  n        <- nrow(y)
  gindex   <- burnin:ng
  
  if(S < 20)SPECLABS <- T
  if(S > 10)CORLINES <- F
  if(S < 4){
    if(GRIDPLOTS)message('no GRIDPLOTS if S < 4')
    GRIDPLOTS <- F
  }
  
  cvec <- c('#e41a1c','#377eb8','#4daf4a','#984ea3','#ff7f00',
            '#a65628','#f781bf','#999999')
  colF <- colorRampPalette( cvec, space = "Lab" )

  if(is.null(specColor))specColor <- colF(S)
  if(is.numeric(specColor))specColor <- colF(S)[ specColor ]
  
  names(specColor) <- .cleanNames(names(specColor))
  
  if(length(specColor) == 1)specColor <- rep(specColor, S)
  boxCol    <- .getColor(specColor,.4)
  
  omit     <- c(which(colnames(y) %in% omitSpec),other)
  notOmit  <- 1:S
  SO       <- length(notOther)
  if(length(omit) > 0)notOmit <- notOmit[-omit]
  SM       <- length(notOmit)
  
  
  xSd <- 0
  if(Q > 1)xSd <- sqrt( diag(cov(x)) )
  
  HOLD <- F
  if(holdoutN > 0)HOLD <- T
  
  if( !TRAITS & !is.null(richness) ){
    
    cvr <- sd( richness[,'obs'], na.rm=T)/mean( richness[,'obs'], na.rm=T)
    
    if(cvr > .5){   # there must be variation in richness
      
      if(TIME)richness[timeZero,] <- NA
      
      w1 <- which(richness[,1] > 0)        # these are missing data
      if(HOLD)w1 <- w1[!w1 %in% holdoutIndex]
      
      xlimit <- range(richness[w1,1])
      
      if(diff(xlimit) > 0){
        
        if(SAVEPLOTS)pdf( file=.outFile(outFolder,'richness.pdf') )
        
        par(mfrow=c(1,2), bty='n', omi=c(.3,.3,0,0), mar=c(3,2,2,1), 
            tcl= tcl, mgp=mgp)
        
        xc <- c('obs','H_obs')
        yc <- c('predMu','H_pred')
        
        for(k in 1:2){
          
          kx <- richness[w1,xc[k]]
          ky <- richness[w1,yc[k]]
          if(k == 2){
            kx <- exp(kx)
            ky <- exp(ky)
          }
          
          ylimit <- range(ky)
          
          rr   <- range(kx,na.rm=T)
          bins <- seq(rr[1] - .5, ceiling(rr[2] + .5), by=1)
          nbin <- length(bins)
          
          rh <- hist(kx,bins,plot=F)
          xy <- rbind(c(bins[1],bins,bins[nbin]),c(0,rh$density,0,0))
          
          xy     <- .gjamBaselineHist(kx,bins=bins)
          xy[2,] <- ylimit[1] + .3*xy[2,]*diff(ylimit)/max(xy[2,])
          
          plot(xy[1,],xy[2,],col='tan',type='s',lwd=2, ylim=ylimit,
               xlab=' ',ylab='')
          polygon(xy[1,],xy[2,],border='brown',col='tan')
          
          if(HOLD){
            xhold <- richness[holdoutIndex,xc[k]]
            yhold <- richness[holdoutIndex,yc[k]]
            if(k == 2){
              xhold <- exp(xhold)
              yhold <- exp(yhold)
            }
            points(xhold,yhold, col='brown', cex=.3)
          }
          
          opt <- list( xlabel='Observed', ylabel='Predicted', col='darkgreen',
                       atx = bins)
          .plotObsPred( xx = kx, yy = ky, add=T, opt = opt)
          
          abline(0,1,lty=2, lwd=2, col='grey')
          
          if(k == 1){
            .plotLabel('a) Richness (no. present)',cex=1.2,above=T)
          }else{
            .plotLabel('b) Diversity (H)',cex=1.2,above=T)
          }
        }
        mtext(side=1, 'Observed', outer=T, line=0)
        mtext(side=2, 'Predicted', outer=T, line=0)
        
        if(!SAVEPLOTS){
          readline('no. species, effective species -- return to continue ')
        } else {
          dev.off( )
        }
      } 
    }
  }
  
  
  ns <- min( c(ng - burnin, 1000) )
  simIndex <- sample(nrow(sgibbs),ns,replace=T)
  simIndex <- sort(simIndex)
  burn <- burnin/ng*1000
  
  tmp <- .expandSigmaChains(snames, sgibbs, otherpar, simIndex, 
                            sigErrGibbs, kgibbs, REDUCT, CHAINSONLY=F, verbose)
  corMu <- tmp$rMu; corSe <- tmp$rSe; sigMu  <- tmp$sMu; sigSe  <- tmp$sSe
  
  sgibbsShort    <- tmp$chainList$schain      #lower.tri with diagonal
  rgibbsShort    <- tmp$chainList$cchain
  
  if(REDUCT){
    kgibbsShort  <- tmp$chainList$kchain
    otherpar     <- output$modelList$reductList$otherpar
  }
  
  if(REDUCT){
    sigmaerror <- mean(sigErrGibbs)
    sinv <- .invertSigma(sigMu,sigmaerror,otherpar,REDUCT)
  } else {
    sinv <- solveRcpp(sigMu[notOther,notOther])
  }
  
  omitBC <- keepBC <- NULL
  if(termB){
    bgibbsShort <- bgibbs[simIndex,]
    betaLab     <- expression( paste('Coefficient matrix ',hat(bold(B))  ))
  }
  if(termR){
    rhoLab   <- expression( paste('Growth matrix ',hat(bold(Rho))  ))
  }
  if(termA){
    alphaLab   <- expression( paste('interaction matrix ',hat(bold(Alpha))  ))
  }
  
  SO <- length(notOther)
  
  fMat <- output$parameters$fmatrix
  
  if( 'factorBeta' %in% names(inputs) & !FACNAMES ){
    fcnames <- names( inputs$factorBeta$factorList )
    if(length(fcnames) > 0){
      for(m in 1:length(fcnames)){
        colnames(fMat) <- .replaceString( colnames( fMat ), fcnames[m], '' )
        rownames(fMat) <- .replaceString( rownames( fMat ), fcnames[m], '' )
      }
    }
  }
  
  corLab    <- expression( paste('Correlation matrix ',hat(bold(R))  ))
  cutLab    <- expression( paste('Partition matrix ',hat(bold(plain(P)))  ))
  
  AA <- F
  if(!SMALLPLOTS)AA <- T
  
  ################if true parameter values
  
  if( TV ){
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'trueVsPars.pdf') )
    
    tl <- sapply(trueValues, length)
    trueValues <- trueValues[ tl > 0 ]
    
    npl <- length( trueValues[ !names(trueValues) %in% c('betaStn','sigma','w')] )
    
    if(TIME)npl <- length(trueValues[!names(trueValues) %in% c('sigma','w')])
    
    mfrow <- .getPlotLayout(npl)
    
    par(mfrow=mfrow,bty='n', oma = c(3,3,1,1), mar = c(2,2,2,1))
    
    if( termB ){
      
      beta <- rmOther( trueValues$beta )
      sc   <- beta*0 + 1
      
      sc <- specColor[ which(sc == 1, arr.ind=T)[,2] ]
      if( length(beta) < 100 ){
        
        .gjamTrueVest( pchains = rmOther( chains$bgibbsUn[burnin:ng,]),
                       true = beta,
                       typeCode, allTypes, colors = sc, label = betaLab)
      } else {
        opt <- list(xlabel='true',
                    xlabel='', ylabel='', nPerBin=length(beta)/10,
                    fill='lightblue', box.col=sc, POINTS=T, MEDIAN=F, add=F)
        .plotObsPred(beta,betaMu, opt = opt)
        .plotLabel( betaLab, above=T)
        abline(0,1,lty=2)
      }
    }
    
    if( 'rho' %in% names(trueValues) ){  # simulator is diagonal for rho
      
      rho <- trueValues$rho
      cols <- colF(S)
      if(length(rho) < 100){
        lgibbs <- chains$lgibbs 
        gi     <- grep('intercept', colnames(lgibbs))
        xlim <- range(rho)
        ylim <- range(lgibbs)
        hline <- F
        
        .gjamTrueVest(lgibbs[burnin:ng,],true=rho[ wL ], xlim = xlim, ylim = ylim,
                      typeCode, allTypes, colors=cols[wL[,2]], label = rhoLab)
        abline( h = 0, lty=2)
      } else {
        opt <- list(xlabel='true',
                    xlabel='', ylabel='', nPerBin=length(rho)/10,
                    fill='lightblue',box.col = cols[wL[,2]],POINTS=T,MEDIAN=F,add=F)
        .plotObsPred(rho[wL],rhoMu[wL],opt = opt)
        .plotLabel( rhoLab, above=T)
        abline(0,1,lty=2)
      }
      
    }
    if('alpha' %in% names(trueValues)){
      alpha  <- trueValues$alpha
      aindex <- parameters$aindex
      aTrue  <- alpha[ aindex[,c('toW','fromW')] ]
      
   #   cols   <- colF(ntypes)
      if(length(alpha) < 100){
        .gjamTrueVest(chains$alphaGibbs[burnin:ng,],true=aTrue,
                      typeCode,allTypes,colors = cols[wA[,2]] ,label = alphaLab)
      } else {
        opt <- list(xlabel='true',
                    xlabel='', ylabel='', nPerBin=length(alpha)/10,
                    fill='lightblue',box.col=cols,POINTS=T,MEDIAN=F,add=F)
        .plotObsPred(alpha[,notOther],alphaMu[,notOther],opt = opt)
        abline(0,1,lty=2)
        .plotLabel( alphaLab, above=T)
      }
      abline( h = 0, lty=2 )
    }
    if( 'corSpec' %in% names(trueValues) ){
      
      cols <- colF(2^ntypes)
      
      corTrue <- trueValues$corSpec
      
      rg   <- rmOther( rgibbsShort )
      cmat <- columnSplit(colnames(rg),'_')
      
      ctrue <- corTrue[ cmat ]
      cmu   <- corMu[ cmat ]
      
   #   cmat <- matrix( unlist( strsplit( colnames(rg), '_' ) ), ncol = 2, byrow=T)
      rci  <- apply( rg, 2, quantile, c(.5,.025,.975) )
      
      xlim <- range(c(-.1,.1, corTrue[cmat]),na.rm=T)
      ylim <- range(c(-.1,.1, rg),na.rm=T)
      
      cols <- colF(ntypes + ntypes*(ntypes-1)/2)
      
      add <- F
      m   <- 1
      combNames <- character(0)
      combCols  <- numeric(0)
      
      box <- F
      
      for(k in 1:length(allTypes)){
        
        wk <- which(typeNames == allTypes[k])
        wk <- wk[wk %in% notOther]
        sk <- names(typeNames)[wk]
        ic <- which(cmat[,1] %in% sk | cmat[,2] %in% sk )
        
        if( length(ic) < 100 ){
          .gjamTrueVest(rci[, ic], true = ctrue[ic],
                        typeCode, allTypes, label=corLab, xlim=xlim, ylim=ylim,
                        colors=cols[m], legend=F, add=add)
          segments( ctrue[ic], rci[2, ic], ctrue[ic], rci[3, ic],
                    col = cols[m], lwd=2)
        } else {
          box <- T
          opt <- list(xlabel='true',
                      xlabel='', ylabel='', fill='lightblue',
                      nPerBin=length(ic)/20, box.col=cols[m], POINTS=T,
                      MEDIAN=F, add=add, atx = c(-1, 0, 1), aty = c(-1, 0, 1))
          .plotObsPred(ctrue[ic], cmu[ic], opt = opt)
          .plotLabel( corLab, above=T)
          if(!add)abline(0,1,lty=2)
        }
        add <- T
        m <- m + 1
      }
    }
 
    
    if('OC' %in% allTypes & 'cuts' %in% names(trueValues)){
      ctmp     <- cutMu 
      wc       <- c(1:ncol( ctmp )) + 1
      ctrue    <- cuts[,wc]
      wf       <- which(is.finite(ctrue*ctmp)[,-1])
      cutTable <- .gjamTrueVest(chains$cgibbs[burnin:ng,wf],true=ctrue[,-1][wf],
                                typeCode,allTypes,colors='black',
                                label=cutLab,legend=F, add=F)
    }
    mtext( 'True', 1, outer = T, line=1 )
    mtext( 'Estimate', 2, outer = T, line=1 )
    
    if(!SAVEPLOTS){
      readline('simulated beta, corSpec vs betaMu, corMu (95%) -- return to continue')
    } else {
      dev.off()
    }
  }
  
  ##################### partition for ordinal
  
  if('OC' %in% typeNames){
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'partition.pdf') )
    
    par( mfrow=c(1,1), bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp )
    
    wk <- which(typeNames == 'OC')
    nk <- length(wk)
    
    cgibbs <- output$chains$cgibbs
    
    
    onames <- snames[wk]
    vnames <- sort(unique(.splitNames(colnames(cgibbs))$vnam[,1]))
   
    cgibbs[!is.finite(cgibbs)] <- NA
    cc <- colSums(abs(cgibbs),na.rm=T)
    cg <- cgibbs[,cc > 0]
 
    if('cuts' %in% names(trueValues))rownames(cuts) <- rownames(cutMu)
    
    c1 <- names(cc)[cc > 0]
    
    colc <- colF(ncol(cutMu))
    
    nk <- length(vnames)
    plot(0,0,xlim=c(0,max(cg,na.rm=T)),ylim=c(1,1+nk),cex=.1,
         xlab='Unit variance scale',
         ylab=' ',yaxt='n')
    .yaxisHorizLabs(vnames,at=c(1:nk))
    
    for(k in 1:length(vnames)){
      
      x1   <- 0
      ym   <- .5
      
      wcg <- grep(vnames[k],colnames(cg))
      if(length(wcg) == 0)next
      
      tmp <- .chains2density(cg,varName=vnames[k], cut=2.5)
      xt  <- tmp$x
      yt  <- tmp$y
      yt  <- .5*yt/max(yt)
      
      yt <- yt + k
      
      for(j in 1:nrow(xt)){
        
        if('cuts' %in% names(trueValues)){
          lines( rep(cuts[vnames[k],j+2],2),c(k,k+1),lty=2,col=colc[j],lwd=3)
        }
        
        xj <- c(xt[j,],xt[j,ncol(xt)],xt[j,1])
        yj <- c(yt[j,],k,k)
        
        x2 <- which.max(yj)
        xm <- .2*x1 + .8*xj[x2]
        
        polygon(xj, yj, border=colc[j], col=.getColor(colc[j], .4), lwd=2)
        if(k == length(vnames)) text(xm,ym+k,j,col=colc[j])
        x1 <- xj[x2]
      }
    }
    .plotLabel('Partition by species',above=T)
    
    if(!SAVEPLOTS){
      readline('cuts vs cutMu -- return to continue')
    } else {
      dev.off()
    }
  }  
  
  ############################
  
  rmspeAll <- sqrt( mean( (y[,notOther] - ypredMu[,notOther])^2,na.rm=T ) )
  
  eBySpec <- sqrt( colMeans( (y[,notOther]/rowSums(y[,notOther]) - 
                                ypredMu[,notOther]/rowSums(ypredMu[,notOther],
                                                           na.rm=T))^2 ) )
  ordFit  <- order(eBySpec)
  
  score <- mean(yscore)
  
  fit <- signif( c(DIC,score,rmspeAll), 5)
  names(fit) <- c('DIC','score','rmspe')
  
  ################## predict y
  
  if( PLOTY ){
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'yPred.pdf') )
    
    npp <- 0
    
    for(k in 1:length(allTypes)){
      wk    <- which(typeCode == k)
      if( length(censor) > 0 ){
        ncc <- 0
        if( typeNames[wk[1]] %in% names(censor) ){
          wm   <- which(names(censor) == typeNames[wk[1]])
          wnot <- wk
          for(m in wm){
            wnot <- wnot[!wnot %in% censor[[m]]$columns]
            npp  <- npp + 1
          }
          if(length(wnot) > 0)npp <- npp + 1
        } else {
          ncc <- ncc + 1
        }
      } else {
        ncc <- 1
      }
      npp <- npp + ncc
    }  
    
    mfrow <- .getPlotLayout(npp)
    
    par( mfrow=mfrow, bty='n', omi=c(.3,.3,0,0), mar=c(3,4,2,1), 
         tcl= tcl, mgp = mgp )
    
    ylab <- ' '
    mk   <- 0
    
    ypred <- ypredMu
    yobs  <- y
    ypred[ymiss] <- yobs[ymiss] <- NA
    if(TIME)ypred[timeZero,] <- NA
    
    for(k in 1:length(allTypes)){
      
      wk    <- which(typeCode == k)
      wk    <- wk[wk %in% notOther]
      wkm   <- wk
      nk    <- nkm <- length(wk)
      censm <- NULL
      wm    <- wall <- 1
      CENS  <- F
      add   <- F
      
      if( length(censor) > 0 ){
        if( typeNames[wk[1]] %in% names(censor) ){
          CENS <- T
          wm   <- which(names(censor) == typeNames[wk[1]])
          wall <- wm
          wnot <- wk
          for(m in wm){
            wnot <- wnot[!wnot %in% censor[[m]]$columns]
          }
          if(length(wnot) > 0)wall <- c(wall,max(wall) + 1)
        }
      }
      
      for(m in wall){
        
        if(CENS){
          if(m %in% wm){
            censm <- censor[[m]]
            wkm   <- censor[[m]]$columns
          } else {
            censm <- NULL
            wkm   <- wnot
          }
          nkm <- length(wkm)
        }
        
        mk <- mk + 1
        
        y1 <- yobs[,wkm,drop=F]
        yp <- ypred[,wkm,drop=F]
        
        ww <- which(is.finite(y1) & is.finite(yp) & y1 >= 0 & yp >= 0)
        sxx <- suppressWarnings( sqrt(y1[ww]) )
        syy <- suppressWarnings( sqrt(yp[ww]) )
        
        opt  <- .getBinSqrt(y1, yp,  nbin = 12 )
        
        if( !typeNames[wk[1]] %in% c('PA','CAT') ){
          
          if(typeNames[wk[1]] == 'FC'){
            at  <- ceiling( 10*max(y1, na.rm=T) )/10
            opt$xtick <- opt$ytick <- opt$atx <- opt$aty <- seq(0, at, by = .1)
            opt$labx <- opt$laby <- opt$atx
            opt$xlim <- opt$ylim <- c(0, at)
            sxx  <- y1[ww]
            syy  <- yp[ww]
          }
          
          xy  <- .gjamBaselineHist( y1 = sxx, bins = opt$atx, ylim = opt$ylim,
                                    nclass=length(opt$atx) )
          
          plot(xy[1,], xy[2,], col='tan', type='s', lwd=2, xlim=opt$xlim,
               ylim = opt$ylim, xlab='', ylab='', xaxt='n', yaxt='n')
          polygon(xy[1,],xy[2,],border='tan',col='wheat')
          
          axis(1, at = opt$xtick, labels = opt$labx)
          axis(2, at = opt$aty, labels = opt$laby, las=2)
          
          opt <- append(opt, list( xlabel='Observed', ylabel='Predicted', col='darkgreen') )
          tmp <- .plotObsPred( xx = sxx, yy = syy, add=T, opt = opt)
          
          abline(0, 1, lty=2, lwd = 2, col = 'grey')
          
        } else {
          
          y11 <- mean(y1,na.rm=T)
          y00 <- 1 - y11
          x11 <- c(-.07,-.07,.07,.07,.93,.93,1.07,1.07,-.07)
          y11 <- c(0,y00,y00,0,0,y11,y11,0,0)
          
          atx <- min(y1):max(y1)
          aty <- atx
          xlim <- range( atx + c(-1,1)*.2 )
          
          plot(NULL,col='tan',type='s',lwd=2, xlim= xlim + 1,ylim=range(aty),
               xlab='Observed',ylab='', xaxt='n',yaxt='n')
          axis(1, at = atx + 1, labels = atx )
          axis(2, at = aty, labels = atx )
          polygon(x11 + 1,y11,border='tan',col='wheat')
        
          stats <- tapply( as.vector(yp), as.vector(y1), quantile, pnorm(c(-1.96,-1,0,1,1.96)) )
          stats <- matrix( unlist(stats), ncol = 2 )
          tmp <- .boxplotQuant( yp ~ y1, stats = stats, xaxt='n', yaxt = 'n', outline=F, 
                                border='darkgreen', whiskcol='darkgreen',
                                boxfill= .getColor('darkgreen', .6), 
                                pars = list(boxwex = 0.1, ylim=range(aty)), lty=1,
                                add = T)
          abline(-1, 1, lty=2, lwd = 2, col = 'grey')
        }
        
        add <- T
        
        if(nhold > 0){
          y1h <- y[holdoutIndex,wkm,drop=F]
          yph <- ypredMu[holdoutIndex,wkm,drop=F]
          points(y1h,yph,col='brown',
                 pch=21, bg='green',cex=.3)
        } 
        
        tf <- .gjamGetTypes(typeNames[wk[1]])$labels
        tf <- paste(letters[mk],tf, sep=') ')
        
        .plotLabel(tf,'topleft',above=AA)
      }
    }
    mtext('Observed', side=1, outer=T)
    mtext('Predicted', side=2, outer=T)
    
    
    if(!SAVEPLOTS){
      readline('obs y vs predicted y -- return to continue ')
    } else {
      dev.off()
    }  
  }
  
  ##########################
  
  nfact <- 0
  factorList <- contrast <- numeric(0)
  
  if( termB ){
    
    nfact <- factorBeta$nfact
    factorList <- contrast <- numeric(0)
    if(!is.null(nfact)){
      factorList <- factorBeta$factorList
      contrast <- factorBeta$contrast
    }
  }
  
  if( termR ){
    
    if(factorRho$nfact > 0){
      
      factorRho$factorList <- factorRho$factorList[ !factorRho$factorList %in% factorList ]
      
      nfact <- nfact + length( factorRho$factorList )
      factorList <- append(factorList, factorRho$factorList)
      contrast   <- append(contrast, factorRho$contrast)
    }
  }
    
  if( PLOTX & PREDICTX & length(xpredMu) > 0 ){
    
    noX <- character(0)
    colorGrad   <- colorRampPalette(c('white','brown','black'))

    iy <- c(1:n)
    if(!is.null(timeZero))iy <- iy[-timeZero]
    
    if( nfact > 0 ){
      
      nn <- length(unlist(factorList)) # + nfact
      mmat <- matrix(0,nn,nn)
      mnames <- rep('bogus',nn)
      samples <- rep(0,nn)
      
      ib <- 1
      
      par(mfrow=c(1,1),bty='n')
      
      mm <- max(nfact,2)
      useCols <- colorRampPalette(c('brown','orange','darkblue'))(mm)
      textCol <- character(0)
      
      for(kk in 1:nfact){
        
        gname <- names( factorList )[[kk]]
        fnames <- factorList[[kk]]
        nx     <- length(fnames)
        if(nx < 1)next
        
        ie <- ib + nx - 1
        
        noX <- c(noX,fnames)
        cont <- contrast[[kk]]
        
        refClass <- names(which( rowSums( cont ) == 0) )
        
        hnames <- substring(fnames, nchar(gname) + 1)
        
        knames <- c(paste(gname,'Ref',sep=''),fnames)
        if(TIME){
          xtrue     <- x[iy,fnames,drop=F]
        }else{
          xtrue <- xUnstand[iy,fnames,drop=F]
        }
       nx    <- ncol(xtrue)
        
        xpred <- xpredMu[iy,fnames,drop=F]
        cmat  <- matrix(0,nx,nx)
        colnames(cmat) <- hnames
        rownames(cmat) <- rev(hnames)
        
        for(j in 1:nx){
          wj <- which(xtrue[,j] == 1)
          cmat[,j] <- rev( colSums(xpred[drop=F,wj,],na.rm=T)/length(wj) )
        }
        
        nb <- nn - ib + 1
        ne <- nn - ie + 1
        samples[ib:ie] <- colSums(xtrue)/n
        
        mmat[ne:nb,ib:ie] <- cmat
        mnames[ib:ie] <- hnames 
        
        textCol <- c(textCol,rep(useCols[kk],nx))
        
        ib <- ie + 1
      }
      
      colnames(mmat) <- mnames
      rownames(mmat) <- rev(mnames)
      
      if(length(mmat) == 1){

        mc <- c(mmat[1], 1 - mmat[1])
        mmat <- cbind(rev(mc),mc)
        fmname <- factorBeta$facList2
        if( length(fmname) == 0 )fmname <- factorRho$facList2
        rownames(mmat) <- colnames(mmat) <- fmname[[1]]
      }
      
      graphics.off()
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'xPredFactors.pdf' ) )
      par(mfrow=c(1,1),bty='n')
      
      slim <- 1.3*c(0,max(mmat))
      if(slim[2] > 1)slim[2] <- 1
      
      .corPlot(mmat,slim=slim,plotScale=.8, textCol = textCol,
               PDIAG=F,CORLINES=T, tri='both',
               SPECLABS = T, colorGrad = colorGrad,
               textSize=1, new=F)
      if(nx > 1){
        mloc <- par('usr')
        text(mean(mloc[1:2]),mloc[3] + .03*diff(mloc[3:4]),'Observed')
        mtext('Predicted',side=4)
      }
      
      if(!SAVEPLOTS){
        readline('x inverse prediction, factors -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    noplot <- c(1,grep(':',xnames),grep('^2',xnames,fixed=T))
    vnames <- xnames[-noplot]
    vnames <- vnames[!vnames %in% noX]
    
    vnames <- vnames[ vnames %in% colnames(xUnstand) ]
    
    if( length(vnames) > 0 ){
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'xPred.pdf') )
      
      ylab <- ''
      xlab <- ''
      mfrow <- .getPlotLayout( length(vnames) )
      par( mfrow=mfrow, bty='n', omi=c(.3,.3,0,0), mar=c(3,2,2,1),
           tcl= tcl, mgp=mgp )
      
      missX <- missingIndex
      xmaxX <- apply(x,2,max,na.rm=T)
      
      k <- 0
      b <- 0
      
      for(j in 2:Q){
        
        if(!xnames[j] %in% vnames)next
        
        k <- k + 1
        b <- b + 1
        if(b == mfrow[2])b <- 0
        
        x1 <- xUnstand[iy,j]
        x2 <- xpredMu[iy,j]
        
        type <- 'CON'
        if(length(inputs$factorBeta$factorList) > 0){
          for(kk in 1:length(inputs$factorBeta$factorList)){
            if( xnames[j] %in% inputs$factorBeta$factorList[[kk]] )type <- 'PA'
            if(all(x[,j] %in% c(0,1)))type <- 'PA'
          }
        }
        
        if(nhold > 0){
          x1 <- x1[-holdoutIndex]
          x2 <- x2[-holdoutIndex]
          y1 <- y1[-holdoutIndex,,drop=F]
          yp <- yp[-holdoutIndex,,drop=F]
        }
        
        xlim <- range(x1, na.rm=T)
        bins <- seq(xlim[1], xlim[2], length=12)
        ylim <- range(x2, na.rm=T)
        
        if(length(bins) > 0){
          breaks <- bins
          nPerBin <- NULL
        }
        
          ncc   <- max( c(100,max(x1, na.rm=T)/20) )
          xy <- .gjamBaselineHist(x1, bins=bins, nclass=ncc)
          xy[2,] <- ylim[1] + .3*xy[2,]*diff(ylim)/max(xy[2,])
          
          plot(xy[1,], xy[2,], col='tan', type='s', lwd=2, xlim=xlim, ylim=ylim,
               xlab=' ', ylab=ylab)
          polygon(xy[1,],xy[2,],border='tan',col='wheat')
          
          
          abline(0,1,lty=2,lwd=3,col='grey')
 
          add <- T
          
          if(nhold > 0){
            points(x[holdoutIndex,j],xpredMu[holdoutIndex,j],col='brown',
                   pch=21, bg='blue',cex=.4)
          } 
        
        opt <- list(log=F, xlabel='Observed', atx = bins, ylabel='Predicted', col='darkgreen', 
                    ylim=ylim, xlim = xlim, add=T)
        tmp <- .plotObsPred(x1, x2, opt = opt)

        if(nhold > 0)points(x[holdoutIndex,j],xpredMu[holdoutIndex,j],
                            col='brown',cex=.3)
        
        abline(0, 1, col='grey', lty=2, lwd=2)
        abline(h = mean(x1, na.rm=T), col='grey', lty=2, lwd=2)
        
        if(length(missX) > 0){
          ww <- which(missX[,2] == j)
          if(length(ww) > 0){
            wz <- missX[ww,]
            if(!is.matrix(wz))wz <- matrix(wz,1)
            points(jitter(ww*0+xmaxX[j]),xpredMu[wz],cex=.6,col='blue')
          }
        }
        
        .plotLabel(paste(letters[j-1],xnames[j],sep=') '), above=AA)
      }
      mtext('Observed',side=1, outer=T)
      mtext('Predicted',side=2,outer=T)
      
      if(!SAVEPLOTS){
        readline('x inverse prediction, covariates -- return to continue ')
      } else {
        dev.off()
      }
    }
  }   
  ######################
  
  if( PLOTALLY ){
    
    yy <- y[,notOther]
    np <- ncol(yy)
    
    npage <- 1
    o   <- 1:np
    if(np > 16){
      npage <- ceiling(np/16)
      np    <- 16
    }
    
    mfrow <- .getPlotLayout(np)

    k   <- 0
    add <- F
    o   <- 1:np
    o   <- o[o <= 16]
    if(length(other) > 0)o   <- o[!o %in% other]
    
    for(p in 1:npage){
      
      file <- paste('yPredBySpec_',p,'.pdf',sep='')
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,file) )
      
      npp <- ncol(yy) - k
      if(npp > np)npp <- np
      mfrow <- .getPlotLayout(np)
      par(mfrow=mfrow, bty='n', omi=c(.3,.5,0,0), mar=c(3,3,2,1), 
          tcl= tcl, mgp=mgp)
      
      for(j in o){
        
        censm <- NULL
        if( length(censor) > 0 ){
          if( typeNames[j] %in% names(censor) ){
            wjc <- which(names(censor) == typeNames[j])
            if(j %in% censor[[wjc]]$columns)censm <- censor[[wjc]]
          }
        }
        
        if(j > ncol(yy))next
        y1 <- yy[,j]
        y1[ y1 < 0 ] <- 0
        yp <- ypredMu[,j]
        if( min(y1) == max(y1) | var(yp, na.rm=T) == 0)next
        
        sxx <- sqrt(y1)
        syy <- sqrt(yp)

        opt  <- .getBinSqrt(y1, yp, nbin = 12 )
        
        if( !typeNames[wk[1]] %in% c('PA','CAT') ){
          
          xy  <- .gjamBaselineHist( sxx, bins = opt$atx, ylim = opt$ylim,
                                    nclass=length(opt$atx) )
          
          plot(xy[1,], xy[2,], col='tan', type='s', lwd=2, xlim=opt$xlim,
               ylim = opt$ylim, xlab='', ylab='', xaxt='n', yaxt='n')
          polygon(xy[1,],xy[2,], border = specColor[j], col = boxCol[j])
          
          axis(1, at = opt$atx, labels = opt$labx)
          axis(2, at = opt$aty, labels = opt$laby, las=2)
          
          opt <- append(opt, list( xlabel='Observed', ylabel='Predicted', 
                                   col = specColor[j]) )
          
          tmp <- .plotObsPred( xx = sxx, yy = syy, add=T, opt = opt)
          abline(0, 1, lty=2, col='grey')
        }  else {
          
          y11 <- mean(y1,na.rm=T)
          y00 <- 1 - y11
          x11 <- c(-.07,-.07,.07,.07,.93,.93,1.07,1.07,-.07)
          y11 <- c(0,y00,y00,0,0,y11,y11,0,0)
          
          atx <- min(y1):max(y1)
          aty <- atx
          xlim <- atx + c(-1,1)*.2
          
          plot(NULL,col='tan',type='s',lwd=2, xlim= xlim + 1,ylim=range(aty),
               xlab='Observed',ylab='', xaxt='n',yaxt='n')
          axis(1, at = atx + 1, labels = atx )
          axis(2, at = aty, labels = atx )
          polygon(x11 + 1,y11, border = specColor[j], col = boxCol[j])
          
          stats <- tapply( as.vector(yp), as.vector(y1), quantile, pnorm(c(-1.96,-1,0,1,1.96)) )
          stats <- matrix( unlist(stats), ncol = 2 )
          tmp <- .boxplotQuant( yp ~ y1, stats = stats, xaxt='n', yaxt = 'n', outline=F, 
                                border=specColor[j], whiskcol=specColor[j],
                                boxfill= boxCol[j], 
                                pars = list(boxwex = 0.1, ylim=range(aty)), lty=1,
                                add = T)
          
          abline(-1, 1, lty=2, lwd = 2, col = 'grey')
        }
        
        k <- k + 1
        if(k > 26)k <- 1
        
        lab <- paste(letters[k],') ',colnames(y)[j],' - ', 
                     typeNames[j], sep='')
        
        .plotLabel( lab,above=T )

        abline(h = mean(yp),lty=2, col='grey')
      }
      mtext('Observed', 1, outer=T)
      mtext('Predicted', 2, outer=T)

      if(!SAVEPLOTS){
        readline('y prediction -- return to continue ')
      } else {
        dev.off()
      }
      o <- o + 16
      o <- o[o <= S]
    }
    
  }
  
  ############## traits
  
  if(TRAITS){
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'traitPred.pdf') ) # start plot
    
    tt <- grep('other',colnames(plotByTrait))
    if(length(tt) > 0)colnames(plotByTrait)[tt] <- colnames(specByTrait)[tt]
    
    traitTypes <- traitList$traitTypes
    ctrait <- traitTypes
    if( !is.null( attr(ctrait, 'CCgroups') ) )ctrait <- paste(ctrait, attr(ctrait, 'CCgroups'), sep='_')
    if( !is.null( attr(ctrait, 'FCgroups') ) )ctrait <- paste(ctrait, attr(ctrait, 'FCgroups'), sep='_')
    
    atr <- unique(ctrait)
    
    tcols <- colF( length(atr) )
    traitColor <- tcols[ match(ctrait, atr) ]
    
               
    yy <- plotByTrait
    o  <- 1:ncol(yy)
    
    if(ncol(yy) > 16){
      
      rmspe <- sqrt( colSums( (plotByTrait - tMu)^2 )/n )
      o <- order(rmspe)[1:16]
      yy <- plotByTrait[,o]
    }
    
    mfrow <- .getPlotLayout(length(o))
    par(mfrow=mfrow, bty='n', oma=oma, mar=c(3,3,1,1), tcl= tcl, mgp=mgp)
    k <- 0
    
    for(j in o){
      
      add   <- F
      jname <- colnames(tMu)[j]
      
      k <- k + 1
      
      td <- plotByTrait[,jname]
      
      tjj   <- tMu[,j]
   #   wj <- which(colnames(tMuOrd) == jname)
      
      wj <- which(colnames(tMu) == jname)
      
      tmp <- .gjamPlotPars(type=traitTypes[j],td,tjj)
      y1 <- tmp$y1; yp <- tmp$yp; nbin <- tmp$nbin; nPerBin <- tmp$nPerBin
      vlines <- tmp$vlines; xlimit <- tmp$xlimit; ylimit <- tmp$ylimit
      breaks <- tmp$breaks; wide <- tmp$wide; LOG <- tmp$LOG; POINTS <- F
      MEDIAN <- tmp$MEDIAN
      
      if(nhold > 0){
        add <- T
        log <- ''
        if(LOG)log <- 'xy'
        plot(td[holdoutIndex],tjj[holdoutIndex],xlab=' ',ylab=ylab,
             xlim=xlimit,ylim=ylimit,col='grey',pch=21,bg='brown',cex=.4,log=log)
      } 
      
      opt <- list( xlabel=' ',ylabel=ylab,nbin=nbin, 
                   nPerBin=nPerBin,
                   xlimit=xlimit,ylimit=ylimit,breaks=breaks,
                   wide=wide,LOG=LOG,
                   fill='grey',
                   col = traitColor[j],
                   POINTS=F,MEDIAN=MEDIAN,add=add )
      
      tmp <- .plotObsPred(td, tjj, opt = opt)
   #   if(length(vlines) > 0)abline(v=vlines,lty=2)
      abline(0,1,lty=2)
      abline(h=mean(td,na.rm=T),lty=2)
      
      .plotLabel( paste(letters[k],') ',.traitLabel(jname),sep=''),above=AA )
    }
    
    if(!SAVEPLOTS){
      readline('predictive trait distributions -- return to continue ')
    } else {
      dev.off()
    }
  }
  
  ##############sensitivity to predictors in beta
  
  if( 'fSensGibbs' %in% names(chains) ){
    
    nfact <- factorBeta$nfact
    
    if(!is.matrix(fSensGibbs)){
      fSensGibbs <- matrix(fSensGibbs)
      colnames(fSensGibbs) <- xnames[-1]
    }
    if( 'factorBeta' %in% names(inputs) & !FACNAMES ){
      fcnames <- names( inputs$factorBeta$factorList )
      if(length(fcnames) > 0){
        for(m in 1:length(fcnames)){
          colnames(fSensGibbs) <- .replaceString( colnames( fSensGibbs ), fcnames[m], '' )
        }
      }
    }
    
    if( ncol(fSensGibbs) > 1 ){
      
      wc <- c(1:ncol(fSensGibbs))
      wx <- grep(':',colnames(fSensGibbs))
      wx <- c(wx, grep('^2',colnames(fSensGibbs), fixed=T) )
      if(length(wx) > 0)wc <- wc[-wx]
      
      wx <- grep('intercept',colnames(fSensGibbs))
      if(length(wx) > 0)wc <- wc[-wx]
      wc <- c(1:ncol(fSensGibbs))
      
      tmp <- apply(fSensGibbs,2,range)
      wx <- which(tmp[1,] == tmp[2,] | tmp[2,] < 1e-12)
      if(length(wx) > 0)wc <- wc[-wx]
      
      if(length(wc) > 0){
        
        if(SAVEPLOTS)pdf( file=.outFile(outFolder,'sensitivity.pdf') ) # start plot
        
        xx   <- fSensGibbs[,wc,drop=F]
        tcol <- rep('black',ncol(xx))
        names(tcol) <- colnames(xx)
        
        if(nfact > 0){
          
          mm <- max(nfact,2)
          useCols <- colorRampPalette(c('brown','orange','darkblue'))(mm)
          
          for(i in 1:nfact){
            im <- which(colnames(xx) %in% rownames(factorBeta$contrast[[i]]))
            tcol[im] <- useCols[i]
          }
        }
        
        par(mfrow=c(1,1),bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
        
     #   if(TIME)par(mfrow=c(1,2),bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
        
        ord  <- order( colMeans(xx) )
        ylim <- c( quantile(xx,.002), 5*quantile(xx,.99))
        tmp <- .boxplotQuant( xx[,ord, drop=F], yaxt='n',outline=F, 
                              border=tcol[ord], whiskcol=tcol[ord],
                              boxfill=.getColor(tcol[ord],.4), 
                              horizontal = TRUE,
                              pars = list(boxwex = 0.5, ylim=ylim), lty=1, log='x')
        sensLab   <- expression( paste('Sensitivity ',hat(bold(F))  ))
        mtext(sensLab,side=1,line=3)
        
        dy <- .05*diff(par()$xaxp[1:2])
        text(dy + tmp$stats[5,],1:length(wc), tmp$names, pos=4,col=tcol[ord], cex=.8)
        
      }
      
      if(!SAVEPLOTS){
        readline('sensitivity over full model -- return to continue ')
      } else { 
        dev.off()
      }
    }
  }
  
  ######################  beta summary tables ############
  
  if( termB ){
    
    fnames <- rownames(factorBeta$eCont)
    
    tmp <- .splitNames(colnames(bgibbs),snames=colnames(y))
    vnames <- unique(tmp$vnam)
    xnam <- unique(tmp$xnam[tmp$xnam != 'intercept'])
  
    if( CHAINS & termB & length(xnam) > 0 ){
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'betaChains.pdf') ) # start plot
      
      cseq <- 1:nrow(bgibbs)
      if(length(cseq) > 1000)cseq <- seq(1,length(cseq),length=1000)
      
      mfrow <- .getPlotLayout(length(xnam))
      par(mfrow=mfrow, bty='n', oma=oma, mar=c(2,2,1,1), tcl= tcl, mgp=mgp)
      
      flist <- factorBeta$factorList
      if(length(flist) > 0){
        flist <- sort(unique(unlist(flist)))
      }
      
      for(k in 1:length(xnam)){
        
        tname <- xnam[k]
        
        tmp   <- .chains2density(bgibbs[drop=F,cseq,],varName=tname, cut=3)
        
        xt  <- tmp$x
        yt  <- tmp$y
        chainMat <- tmp$chainMat
        
        if(ncol(chainMat) > 20)chainMat <- chainMat[,sample(ncol(chainMat),20)]
        
        cols <- colF(nrow(xt))
        
        snamek <- .splitNames(colnames(chainMat),colnames(y))$vnam
        
        nn <- nrow(chainMat)
        
        jk <- 1:ncol(chainMat)
        if(length(jk) > 20)jk <- sample(jk,20)
        plot(0,0,xlim=c(0,(1.4*nn)),ylim=range(chainMat[,jk]),
             xlab=' ',ylab=' ',cex=.01)
        
        for(j in jk){
          lines(chainMat[,j],col=cols[j])
          if(ncol(chainMat) < 15)text(nn,chainMat[nn,j],snamek[j],col=cols[j],pos=4)
          abline(v=burn,lty=2)
          
          if(k == 1 & j == 1).plotLabel( paste(burnin,":",ng),
                                         location='topright' )
        }
        .plotLabel(label=paste(letters[k],') ',tname,sep=''),
                   location='topleft',above=T)
        
        abline(h=0,lwd=4,col='white')
        abline(h=0,lty=2)
        
        if(ncol(chainMat) >= 15) text(nn,mean(par('usr')[3:4]),
                                      paste(ncol(chainMat),'spp'),pos=4)
      }
      
      if(!SAVEPLOTS){
        readline('beta coefficient thinned chains -- return to continue ')
      } else {
        dev.off()
      }
    }
  }
  
  ######################### correlation chains, species at random
  
  if( CHAINS ){
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'corChains.pdf') ) # start plot
    
    par(mfrow=c(2,2), bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
    
    w0 <- 1:ncol(sgibbs)
    if(REDUCT){
      same <- .sameByColumn(kgibbs)
      w0   <- order(same[lower.tri(same,diag=T)])
    } else {
      w0 <- sample(max(w0),80,replace=T)
    }
    ww <- 1:20
    
    for(jj in 1:4){
      
      ssj <- w0[ww]
      ssj <- ssj[is.finite(ssj)]
      if(length(ssj) == 0)break
      if(max(ssj) > max(w0))break
      ww  <- ww + 20
      
      tmp   <- .chains2density(rgibbsShort[,ssj])
      xt    <- tmp$x
      yt    <- tmp$y
      chainMat <- tmp$chainMat
      
      cols <- colF(nrow(xt))
      stk  <- .splitNames(colnames(chainMat))$vnam
      
      ws <- which(stk[,1] == stk[,2])
      if(length(ws) > 0){
        stk <- stk[-ws,]
        chainMat <- chainMat[,-ws]
      }
      
      rr <- range(chainMat)
      if(!is.finite(rr[1]) | !is.finite(rr[2]))next
      
      if(is.matrix(chainMat)){
        
        snamek <- stk[,1]
        nn <- nrow(chainMat)
        plot(0,0,xlim=c(0,(1.4*nn)),ylim=range(chainMat),xlab=' ',ylab=' ',cex=.01)
        
        jk <- 1:ncol(chainMat)
        if(length(jk) > 20)jk <- sample(jk,20)
        
        for(j in jk){
          lines(chainMat[,j],col=cols[j])
          if(ncol(chainMat) < 15)text(nn,chainMat[nn,j],snamek[j],col=cols[j],pos=4)
          
        }
        
        if(jj == 1).plotLabel( paste(burnin,":",ng),location='topright' )
        abline(h=0,lwd=4,col='white')
        abline(h=0,lty=2)
        abline(v=burn,lty=2)
        
        if(ncol(chainMat) >= 15) text(nn,mean(par('usr')[3:4]),
                                      paste(ncol(chainMat),'spp'),pos=4)
      }
    }
    
    if(!SAVEPLOTS){
      readline('correlation thinned chains -- return to continue ')
    } else {
      dev.off()
    }
  }
  
    ##################### time chains
  
  if( TIME & CHAINS ){
    
    if( termR ){
      
      cseq <- 1:nrow(lgibbs)
      if(nrow(lgibbs) > 1000)cseq <- seq(1,length(cseq),length=1000)
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'rhoChains.pdf') ) 
      
      tmp <- .splitNames(colnames(lgibbs),colnames(y))
      vnames <- unique(tmp$vnam)
      xnam <- unique(tmp$xnam)
      
      mfrow <- .getPlotLayout(length(xnam))
      par(mfrow=mfrow, bty='n', oma=oma, mar=c(2,2,1,1), tcl= tcl, mgp=mgp)
      
      for(k in 1:length(xnam)){
        
        tname <- xnam[k]
        
        tmp <- .chains2density(lgibbs[cseq,],varName=tname, cut=3)
        xt  <- tmp$x
        yt  <- tmp$y
        chainMat <- tmp$chainMat
        
        if(ncol(chainMat) > 20)chainMat <- chainMat[,sample(ncol(chainMat),20)]
        
        cols <- colF(nrow(xt))
        
        snamek <- .splitNames(colnames(chainMat),colnames(y))$vnam
        
        nn <- nrow(chainMat)
        
        jk <- 1:ncol(chainMat)
        if(length(jk) > 20)jk <- sample(jk,20)
        plot(0,0,xlim=c(0,(1.4*nn)),ylim=range(chainMat[,jk]),
             xlab=' ',ylab=' ',cex=.01)
        
        for(j in jk){
          lines(chainMat[,j],col=cols[j])
          if(ncol(chainMat) < 15)text(nn,chainMat[nn,j],snamek[j],col=cols[j],pos=4)

          if(k == 1 & j == 1).plotLabel( paste(burnin,":",ng),
                                         location='topright' )
        }
        if(k == 1)tname <- character(0)
        lab <- paste('rho',tname)
        .plotLabel(label=paste(letters[k],') ',lab,sep=''),location='topleft',above=T)
        
        abline(h=0,lwd=4,col='white')
        abline(h=0,lty=2)
        
        if(ncol(chainMat) >= 15) text(nn,mean(par('usr')[3:4]),
                                      paste(ncol(chainMat),'spp'),pos=4)
        
        abline(v=burn,lty=2)
      }
      
      if(!SAVEPLOTS){
        readline('rho coefficient chains -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    if( termA ){
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'alphaChains.pdf') ) 
      
      cseq <- 1:nrow(alphaGibbs)
      if(length(cseq) > 1000)cseq <- seq(1,length(cseq),length=1000)
      
      kp <- min(c( 4, floor(S/4) ) )
      ka <- c(1:S)
      
      if(kp  > 0){
        
        np <- min(c(S,4))
        mfrow <- .getPlotLayout(np)
        par(mfrow=mfrow, bty='n', oma=oma, mar=c(2,2,1,1), tcl= tcl, mgp=mgp)
        
        
        for(k in 1:np){
          
          wc <- sample(ka,kp)
          ka <- ka[!ka %in% wc]
          
          tmp <- .chains2density(alphaGibbs[drop=F, cseq,wc], cut=3)
          xt  <- tmp$x
          yt  <- tmp$y
          chainMat <- tmp$chainMat
          
          cols <- colF(nrow(xt))
          
          snamek <- .splitNames(colnames(chainMat),colnames(y))$vnam
          
          nn <- nrow(chainMat)
          
          jk <- 1:ncol(chainMat)
          if(length(jk) > 20)jk <- sample(jk,20)
          plot(0,0,xlim=c(0,(1.4*nn)),ylim=range(chainMat[,jk]),
               xlab=' ',ylab=' ',cex=.01)
          
          for(j in jk){
            lines(chainMat[,j],col=cols[j])
            if(ncol(chainMat) < 15)text(nn,chainMat[nn,j],snamek[j],
                                        col=cols[j],pos=4)
            
            if(k == 1 & j == 1).plotLabel( paste(burnin,":",ng),
                                           location='bottomright' )         }
          abline(h=0,lwd=4,col='white')
          abline(h=0,lty=2)
          
          abline(v=burn,lty=2)
          
          if(ncol(chainMat) >= 15) text(nn,mean(par('usr')[3:4]),
                                        paste(ncol(chainMat),'spp'),pos=4)
        }
        
        if(!SAVEPLOTS){
          readline('example alpha coefficient chains -- return to continue ')
        } else {
          dev.off()
        }
      }
    }
  }
  
  ############################### beta posteriors as boxes
  
  if( termB & length(bFacGibbs) > 0 ){
    
    bfSig <- bFacGibbs
    
    tmp <- .splitNames(colnames(bfSig), snames)
    vnam <- tmp$vnam
    xnam <- tmp$xnam
    
    fnames  <- unique( xnam )
    xpNames <- .replaceString(fnames,':','X')
    xpNames <- .replaceString(xpNames,'I(','')
    xpNames <- .replaceString(xpNames,')','')
    xpNames <- .replaceString(xpNames,'^2','2')
    xpNames <- .replaceString(xpNames,'*','TIMES')
    brange  <- apply(bfSig,2,range)
    
    for(j in 1:length(fnames)){
      
      wc <- which(xnam == fnames[j] & brange[2,] > brange[1,])
      if(length(wc) < 2)next
      
      plab <- paste('beta_',xpNames[j],'.pdf',sep='')
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,plab) ) # start plot
      
      par(mfrow=c(1,1),bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
      
      .myBoxPlot( mat = bfSig[,wc], tnam = vnam[ wc ], snames = snames,
                  specColor, label=fnames[j], LEG=F)
      mtext(side=2,'Coefficient', line=2)
      
      if( !is.null(names(specColor)) ){
        lf <- sort( unique(names(specColor)) )
        cc <- specColor[lf]
        legend('bottomright',names(cc), text.col = cc, bty='n')
      }
      
      if(!SAVEPLOTS){
        readline('beta standardized for W/X, 95% posterior -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    #one figure
    
    if(length(fnames) > 1){
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'betaAll.pdf') )  
      
      npp <- length(which(table(match(xnam,fnames)) > 1))
      
      mfrow <- .getPlotLayout(npp)
      par( mfrow=mfrow, bty='n', omi=c(.3,.5,0,0), 
           mar=c(1,1,1,1), tcl= tcl )
      
      k <- 0
      for(j in 1:length(fnames)){
        
        wc <- which(xnam == fnames[j])
        if(length(wc) < 2)next
        
        k <- k + 1
        
        .myBoxPlot( mat = bfSig[,wc], tnam = vnam[ wc ], snames = snames,
                    specColor, label=' ', LEG=F)
        .plotLabel(fnames[j],'topleft')
      }
      mtext(side=2,'Coefficient value',outer=T, line=1)
      
      if(!SAVEPLOTS){
        readline('95% posterior -- return to continue ')
      } else {
        dev.off()
      }
    }
    
  }
  
  ############################## time #######################
  
  if( termR ){
    
    lgibbs <- chains$lgibbs  #rho
    
    tmp  <- .splitNames(colnames(chains$lgibbs), snames)
    vnam <- tmp$vnam
    xnam <- tmp$xnam 
    gnames <- unique(xnam)
    
    k <- 0
    
    for(j in 1:length(gnames)){
      
      wc <- which(xnam == gnames[j])
      if(length(wc) < 2)next
      
      k <- k + 1
      
      plab <- paste('rho_',gnames[j],'.pdf',sep='')
      if(j == 1){
        glab <- 'rho'
      }else{
        glab <- paste('rho:',gnames[j])
      }
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,plab) ) # start plot
      par(mfrow=c(1,1),bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
      
      .myBoxPlot( mat = lgibbs[,wc], tnam = vnam[ wc ], snames = snames,
                  specColor, label=glab)
      if(!SAVEPLOTS){
        readline('95% posterior -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    if(length(gnames) > 1){
      # one plot
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'rhoAll.pdf') )  
      
      npp <- length(which(table(match(xnam,gnames)) > 1))
      mfrow <- .getPlotLayout(npp)
      par( mfrow=mfrow, bty='n', oma=oma, mar=c(2,2,1,1), tcl= tcl, mgp=mgp )
      
      k <- 0
      for(j in 1:length(gnames)){
        
        wc <- which(xnam == gnames[j])
        if(length(wc) < 2)next
        
        k <- k + 1
        if(j == 1){
          glab <- 'rho'
        }else{
          glab <- paste('rho:',gnames[j])
        }
        .myBoxPlot( mat = lgibbs[,wc], tnam = vnam[ wc ], snames = snames,
                    specColor, label=glab)
      }
      
      if(!SAVEPLOTS){
        readline('95% posterior -- return to continue ')
      } else {
        dev.off()
      }
    }
  }  ### end time ##
  
  ############################### beta posteriors, traits
  
  if(TRAITS){
    
    M  <- nrow(specByTrait)
    bt <- chains$bTraitFacGibbs
    wi <- grep( ':', colnames(bt) )
    if(length(wi) > 0)bt <- bt[,-wi] # remove interactions
    
    vnam   <- columnSplit( colnames(bt), '_')
    mnames <- colnames(specByTrait)
    xnam   <- vnam[,2]
    vnam   <- vnam[,1]
    
    if(length(traitColor) == 1)traitColor <- rep(traitColor, M)
    tboxCol <- .getColor(traitColor,.4)
    
    traitSd <- apply(plotByTrait,2,sd,na.rm=T)
   # traitSd <- matrix(traitSd,nrow(bt),length(traitSd),byrow=T)
    
    for(j in 2:length(xnames)){
      
      wc <- which(xnam == xnames[j])
      if(length(wc) < 2)next
      
      mt <- match( names(traitSd), vnam[wc] )
      mx <- which( names(xSd) == xnames[j] )
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'traits.pdf') ) # start plot
      
      par(mfrow=c(1,1),bty='n', oma=oma, mar=mar, tcl= tcl, mgp=mgp)
      
      tsd <- matrix(traitSd[mt], nrow(bt), length(mt), byrow=T)
      
      mat <- bt[,wc]*xSd[mx]/tsd
      
      vn  <- .splitNames(colnames(mat))$vnam[,1]
      
      .myBoxPlot( mat, tnam = vn, snames = mnames,
                  traitColor, label='', LEG=F )
      
      .plotLabel(xnames[j],location='bottomright')  
      
      if(!SAVEPLOTS){
        readline('traits, standardized for X/W, 95% posterior -- return to continue ')
      } else {
        dev.off()
      }
    }
  }
  
  ########### cluster analysis
  
  covx <- cov(x)
  covy <- cov(y[,notOmit])
  
  nsim <- 500
  if(S > 50)nsim  <- 100
  if(S > 100)nsim <- 20
  eVecs <- eValues <- NULL
  
  if( !TIME | (TIME & termB) & !is.null(ematrix) ){
    tmp     <- eigen( ematrix )
    eVecs   <- tmp$vectors
    eValues <- tmp$values
    rownames(eVecs) <- snames[notOther]
  }
  
  
  ########### dimension reduction ############
  
  if( REDUCT ){ 
    
    graphics.off()
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'dimRed.pdf') ) # start plot
    
    mk <- .modalValuesInArray(kgibbs,2)[notOmit]
    NK <- table( table(mk) )
    mk <- length(NK)
    
    r <- otherpar$r
    
    par(bty='n')
    scale <- SO/3
    if(SMALLPLOTS)scale <- 10*scale
    .mapSetup(c(1,SO),c(1,SO),scale=scale)
    
    xl <- SO/15
    yl <- SO/8
    
    en <- SO*(SO+1)/2
    
    plot(0,0,xlim=c(0,SO+xl),ylim=c(0,SO+xl),cex=.01,xaxt='n',yaxt='n',
         xlab=' ',ylab=' ')
    
    rect(xl,yl,SO+xl,SO+yl,col='wheat',border='wheat',lty=2,lwd=2)
    polygon(c(xl,SO+xl,xl),c(yl,yl,SO+yl),col='blue',border='darkblue')
    rect(0,yl/10,r,mk+yl/10,col='blue',border='wheat', lwd=2)
    
    text(xl+SO/4,yl+SO/3,bquote(Sigma == .(en)), col='wheat', cex=1.4 )
    text(r, yl/20*(mk + 1),
         paste('Z (',mk,' x ',r,' = ',mk*r,')',sep=''),col='blue',
         cex=1.,pos=4)
    .plotLabel('Dimensions','topright')
    
    if(!SAVEPLOTS){
      readline('reduction from sigma to Z -- return to continue ')
    } else {
      dev.off()
    }
  } 
  
  if(TIME){  ################ variance components
    
    sensMu <- sensSe <- numeric(0)
    acol   <- colF(3)
    names(acol) <- c('movement','DI growth','DD growth')
    scol   <- character(0)
    
    if( 'sensBeta' %in% names(parameters) ){
      if( var( sensBeta[,1]) != 0 ){
        sensMu <- cbind(sensMu, sensBeta[,1])
        sensSe <- cbind(sensSe, sensBeta[,1])
        colnames(sensMu)[ncol(sensMu)] <- colnames(sensSe)[ncol(sensMu)] <- 'beta'
        scol <- c(scol, acol[1])
      }
    }
    if( 'sensRho' %in% names(parameters) ){
      sensMu <- cbind(sensMu, sensRho[,1])
      sensSe <- cbind(sensSe, sensRho[,1])
      colnames(sensMu)[ncol(sensMu)] <- colnames(sensSe)[ncol(sensMu)] <- 'rho'
      scol <- c(scol, acol[2])
    }
    if( 'sensAlpha' %in% names(parameters) ){
      sensMu <- cbind(sensMu, sensAlpha[,1])
      sensSe <- cbind(sensSe, sensAlpha[,1])
      colnames(sensMu)[ncol(sensMu)] <- colnames(sensSe)[ncol(sensMu)] <- 'alpha'
      scol <- c(scol, acol[3])
    }
    
    if( length(sensMu) > 0 ){
      
      osens <- order( colMeans(sensMu), decreasing=T )
      
      sensMu <- sensMu[,osens,drop = FALSE]
      sensSe <- sensSe[,osens,drop = FALSE]
      scol   <- scol[ osens ]
      
      nc <- ncol(sensMu)
      sensMu <- sensMu[drop = FALSE, notOther,]
      sensSe <- sensSe[drop = FALSE, notOther,]
      
      
      # total variance
      ord <- order(sensMu[,1], decreasing = T)
      
      graphics.off()
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'varianceComponents.pdf') ) # start plot
      
      mfrow <- c(1,1)
      if(nc > 1)mfrow <- c(2,1)
      par( mfrow = mfrow, bty = 'n', mar = c(3,4,1,2) )
      
      if(nc > 1){
        #proportion of total
        
        sigma <- sqrt( diag( sigMu )[notOther] ) #sensAlpha, sensRho, sensBeta on sd scale
        sens  <- cbind(sensMu, sigma)
        sprop <- sweep( sens, 1, rowSums(sens), '/')
        ord <- order(sprop[,1], decreasing = T)
        
        smu <- t(sprop[ord,])
        smu <- smu[drop=F, 1:(nrow(smu)-1),]
        smax <- max( colSums(smu) )
        tmp <- barplot( smu, beside = F, col = .getColor(scol, .4), border = scol, xaxt = 'n',
                        ylim = c(0, smax), ylab = 'Proportion of total SD' )
        text( tmp - .2*diff(tmp)[1], .04, colnames(smu), srt = 90, pos = 4, cex=.9)
      }
      
      smu <- t(sensMu[drop=F, ord,])
      sse <- t(sensSe[drop=F, ord,])
      
      tmp <- barplot( smu, beside = T, col = .getColor(scol, .4), border = scol, xaxt = 'n',
                      ylim = 1*c(0, max(smu + sse)), ylab = 'Std deviation scale' )
      for(j in 1:nc){
        errorBars( tmp[j,], smu[j,], smu[j,] + sse[j,], col = scol[j], code=3, length=.04)
      }
      if(nc == 1)text( tmp[1,], 1.05*apply(smu + sse, 2, max), colnames(smu), srt = 75, pos = 4,
                       cex = .9)
      legend('topright', legend = names(scol), text.col = scol, bty='n')
      
      
      if(!SAVEPLOTS){
        readline('contributions to dynamics -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    if( !is.null(alphaEigen) ){ # eigenvalues
      
      graphics.off()
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'alphaEigenValues.pdf') ) # start plot
      
      par( mfrow = c(1,1), bty = 'n')
      
      if(!is.complex(alphaEigen)){
        plot( alphaEigen, alphaEigen*0 , pch=15, xlim = c(-1, 1), ylim = c(-1, 1),
              xlab = 'Real', ylab = 'Imaginary')
      }else{
        plot(alphaEigen, pch=15 ) #, xlim = c(-1, 1) ) , ylim = c(-1, 1) )
      }
      abline(h = 0, lty=2, lwd = 2, col = 'grey')
      abline(v = 0, lty=2, lwd = 2, col = 'grey')
      xs <- seq(-1, 1, length=100)
      ys <- sqrt(1 - xs^2)
      lines(xs, ys, lwd=2, lty=2, col = 'grey')
      lines(xs, -ys, lwd=2, lty=2, col = 'grey')
      
      if(!SAVEPLOTS){
        readline('eigenvalues of alpha -- return to continue ')
      } else {
        dev.off()
      }
    }
  }
  
  if( !GRIDPLOTS ){
    
    clusterIndex <- NULL
    clusterOrder <- NULL
    
    if( S >= 8 & !is.null(ematrix) ){
      opt <- list( ncluster=ncluster, PLOT=F, DIST=F )
      clusterDat <- .clusterPlot( ematrix , opt)
      colCode    <- clusterDat$colCode
      cord       <- rev(clusterDat$corder)
      dord       <- notOther[!notOther %in% omit][cord]
      
      clusterIndex <- clusterDat$clusterIndex
      clusterOrder <- clusterDat$corder
    }
    
    invisible( return( list(fit = fit, 
                            ematrix = ematrix, clusterIndex = clusterIndex, 
                            clusterOrder = clusterOrder) ) )
  }
  
  if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterDataE.pdf') ) # start plot
  
  mag <- mar
  mag[4] <- max(mar[4],6)
  par(mfrow=c(1,2), cex=.7, oma=oma, mar=mag, tcl= tcl, mgp=mgp)
 
  LABELS <- T
  if(S > 100 | !SPECLABS)LABELS <- F
  
  dcor <- .cov2Cor(covy)
  dcor[is.na(dcor)] <- 0
  
  opt <- list( main='',cex=.2,ncluster=ncluster,
               colCode=specColor[notOmit], textSize=.4, 
               LABELS = LABELS, DIST=F )
  tmp <- .clusterPlot( dcor, opt)
  colCode <- tmp$colCode
  
  clusterIndex <- tmp$clusterIndex
  clusterOrder <- tmp$corder
  
  .plotLabel('a) Data correlation',above=T, cex=1.7)
  
  if( !is.null(ematrix) ){
    emm   <- ematrix
    emm   <- .cov2Cor(emm)
  
    tmp   <- .clustMat(emm, SYM = T)#########
    ecor <- tmp$cmat
    
    opt <- list( main='',cex=.2, ncluster=ncluster, 
                 colCode=specColor[notOmit], textSize=.5, 
                 LABELS = LABELS, DIST=F)
    tmp <- .clusterPlot( ecor , opt ) #######################
    .plotLabel('b) E correlation',above=T, cex=1.7)
    
    clusterIndex <- cbind( clusterIndex, tmp$clusterIndex )
    clusterOrder <- cbind( clusterOrder, tmp$corder )
    
    rownames(clusterIndex) <- rownames(clusterOrder) <- snames[notOmit]
    colnames(clusterIndex) <- colnames(clusterOrder) <- c('data','E')
  }
  
  if(!SAVEPLOTS){
    readline('Data and E responses to X -- return to continue ')
  } else {
    dev.off()
  }
  
  ########### E communities
  
  
  if( !is.null(ematrix) ){
    
    imat <- output$inputs$y
    imat[imat > 0] <- 1
    iord <- colSums(imat)
    etab  <- table(clusterIndex[,'E'])
    eComs <- matrix(NA,ncluster, max(etab))
    ename <- rep( character(0), max(etab) )
    
    egroup <- clusterIndex[,'E']
    
    for(j in 1:ncluster){
      
      wj <- which(clusterIndex[,'E'] == j)
      jname <- rownames(clusterIndex)[wj]
      jname <- jname[order(iord[jname],decreasing=T)]
      eComs[j,1:length(jname)] <- jname
      mm    <- min( c(3,length(jname)) )
      jj    <- substr(jname[1:mm],1,6)
      ename[j] <- paste0(jj,collapse='_')
    } 
    rownames(eComs) <- ename
    eComs <- t(eComs)
    
    ########### ordination
    
    if( !is.null(eVecs) ){
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'ordination.pdf') ) # start plot
      
      clusNames <- eComs[1,]
      
      lambda <- eValues/sum(eValues)
      cl     <- cumsum(lambda)
      
      cbord <- .getColor(specColor[notOther],.4)
      cfill <- .getColor(specColor[notOther],.4)
      
      par(mfcol=c(2,2), bty='n', cex = cex, mar=c(4,4,1,1))
      
      p1 <- paste('Axis I (',round(100*lambda[1],0),'%)',sep='')
      p2 <- paste('Axis II (',round(100*lambda[2],0),'%)',sep='')
      p3 <- paste('Axis III (',round(100*lambda[3],0),'%)',sep='')
      
      xlim <- range(eVecs[,1])
      
      plot(eVecs[,1],eVecs[,2],cex=1,col=cbord, bg = cfill, pch=16,
           xlab=p1, ylab = p2) 
      abline(h=0,col=.getColor('black',.1),lwd=2,lty=2)
      abline(v=0,col=.getColor('black',.1),lwd=2,lty=2)
      
      text(eVecs[clusNames,1],eVecs[clusNames,2],substr(clusNames,1,7))
      
      plot(eVecs[,1],eVecs[,3],cex=1,col=cbord, bg = cfill, pch=16,
           xlab=p1, ylab = p3) 
      abline(h=0,col=.getColor('black',.1),lwd=2,lty=2)
      abline(v=0,col=.getColor('black',.1),lwd=2,lty=2)
      
      text(eVecs[clusNames,1],eVecs[clusNames,3],substr(clusNames,1,7))
      
      plot(eVecs[,2],eVecs[,3],cex=1,col=cbord, bg = cfill, pch=16,
           xlab=p2, ylab = p3)
      abline(h=0,col=.getColor('black',.1),lwd=2,lty=2)
      abline(v=0,col=.getColor('black',.1),lwd=2,lty=2)
      
      text(eVecs[clusNames,2],eVecs[clusNames,3],substr(clusNames,1,7))
      
      plot(cl,type='s',xlab='Rank',ylab='Proportion of variance',xlim=c(.9,S),
           ylim=c(0,1),log='x')
      lines(c(.9,1),c(0,cl[1]),lwd=2,type='s')
      for(j in 1:length(lambda))lines(c(j,j),c(0,cl[j]),col='grey')
      lines(cl,lwd=2,type='s')
      abline(h=1,lwd=2,col=.getColor('grey',.5),lty=2)
      
      if(!SAVEPLOTS){
        readline('ordination of E matrix -- return to continue ')
      } else {
        dev.off()
      }
    }
  }
  
  
  ########### grid/correlation analysis
  
  if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterGridR.pdf') )
  
  par(mfrow=c(1,1),bty='n',cex=1, oma=oma, mar=mag, tcl= tcl, mgp=mgp)
  
  colnames(corMu) <- rownames(corMu) <- colnames(y)
  
  psize <- .62
  if(SMALLPLOTS)psize <- psize/2
  
  par(plt=c(.03,.15,.1,.9), bty='n', new=F)
  opt <- list( main=' ',cex=.2, ncluster=ncluster, 
               colCode=specColor[notOmit], textSize=.5, 
               LABELS = F, DIST=F )
  tmp <- .clusterPlot( corMu[notOmit,notOmit] , opt)
  colCode   <- tmp$colCode
  corder    <- rev(tmp$corder)
 # specOrder <- snames[notOmit[corder]]
  rOrder <- snames[notOmit[corder]]
  
  clusterIndex <- cbind( clusterIndex, tmp$clusterIndex )
  clusterOrder <- cbind( clusterOrder, tmp$corder )
  
  ncc <- ncol(clusterIndex)
  colnames(clusterIndex)[ncc] <- colnames(clusterOrder)[ncc] <- 'R'
  
  if(LABELS){
    
    par(plt=c(.15,.33,.1,.9), bty='n', new=T)
    plot(c(0,0),c(0,0),col='white',xlim=range(c(0,1)),ylim=c(0,SO),
         xaxt='n',yaxt='n',xlab='',ylab='')
    xl <- rep(.5,SO)
    
    yl <- c(1:SO) + par('usr')[3] - .75
    cex <- .fitText2Fig(rOrder,fraction=1.2)
    text( xl,yl,rev(rOrder),pos=3,cex=cex, col=rev(colCode[corder]))
  }
  
 # knames <- snames[notOmit]
  
  tmp <- .invMatZero(sgibbs,nsim=nrow(sgibbs),snames=snames,
                     knames=rOrder,index=NULL, COMPRESS=T, 
                     REDUCT=REDUCT,
                     sigErrGibbs = output$chains$sigErrGibbs, 
                     kgibbs = output$chains$kgibbs,
                     otherpar = otherpar, alpha=ematAlpha)
  marIn <- tmp$inMarMat
  conIn <- tmp$inConMat
  wm    <- which(marIn[,1] %in% omit |  marIn[,2] %in% omit)
  if(length(wm) > 0)marIn <- marIn[-wm,]
  wm    <- which(conIn[,1] %in% omit |  conIn[,2] %in% omit)
  if(length(wm) > 0)conIn <- conIn[-wm,]
  
  sigCor <- c(nrow(marIn),nrow(conIn))/SM/(SM - 1)
  sigCor <- round(100*sigCor,0)
  names(sigCor) <- c('n_marIn','n_conIn')
  
  mor <- notOmit[corder]
  
  crr <- corMu[mor,mor]
  marIn[,1] <- match(marIn[,1],mor)
  marIn[,2] <- match(marIn[,2],mor)
  conIn[,1] <- match(conIn[,1],mor)
  conIn[,2] <- match(conIn[,2],mor)
  
  makeCR <- list('white' = conIn,'grey' = marIn)
  if(!is.null(specColor))textCol = colCode[mor]
  
  par(plt=c(.33, .33 + psize,.1,.9), bty='n', new=T)
  
  slim <- quantile(crr[lower.tri(crr)],c(.05,.95))
  
  SPECLABS <- F
  if(S < 30)SPECLABS <- T
  
  .corPlot(crr, slim=slim, makeColor=makeCR,plotScale=.99,
           PDIAG=T,CORLINES=CORLINES, textCol = colCode[corder], 
           SPECLABS = SPECLABS, squarePlot = F,
           textSize=1, widex = width, widey = height, new=T, add=F)
  
  ll <- paste(c('Cond Ind (white) = ', 'Cond & Marg Ind (grey) = '),
              sigCor,c('%','%'),sep='')
  legend('topright',ll,bty='n',cex=.8)
  
  .plotLabel(expression( paste(hat(bold(R)),'structure'  )),above=T, cex=.9)
  
  if(!SAVEPLOTS){
    readline('posterior correlation for model -- return to continue ')
  } else {
    dev.off()
  }
  
  ########################### cluster Fmat with beta
  
  fBetaMu <- output$parameters$betaStandXWmu
  
  if( 'factorBeta' %in% names(inputs) & !FACNAMES){
    fcnames <- names( inputs$factorBeta$factorList )
    for(m in 1:length(fcnames)){
      colnames(fBetaMu) <- .replaceString( colnames( fBetaMu ), fcnames[m], '' )
    }
  }
  
  if(Q > 4 & !is.null(fMat)){
    
    main1 <- expression( paste('Sensitivity ',hat(F)))
    main2 <- expression( paste('Responses ',hat(B)))
    
    ws <- which( rowSums(fMat) == 0)
    if(length(ws) > 0){
      not0 <- c(1:nrow(fMat))[-ws]
      fMat <- fMat[drop=F,not0,not0] 
      rn   <- intersect( rownames(fMat), rownames(fBetaMu) )
      fMat <- fMat[drop=F,rn,rn]
      fBetaMu <- fBetaMu[rn,]
    }
    
    mat1 <- fMat
    mat2 <- fBetaMu
    expand <- ncol(mat1)/ncol(mat2)
    expand <- max(c(1.,expand))
    
    expand <- min( c(1.5, expand) )
    
    if(nrow(fMat) > 3){
      
      graphics.off()
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'gridF_B.pdf') ) # start plot
      
      opt <- list(mainLeft=main1, main1=main1, main2 = main2,
                  topClus1=T, topClus2=T, rightLab=F, topLab1=T, 
                  topLab2 = T, leftLab=T, ncluster = ncluster,
                  colCode2 = specColor[notOther], lower1 = T, diag1 = T,
                  lower2 = F)
      tr <- try( 
      .clusterWithGrid(mat1, mat2, expand=expand, opt), TRUE
      )
      if( inherits(tr,'try-error') ){
        .clusterWithGrid(mat1, mat2, expand=1, opt)
      }
      
      
      if(!SAVEPLOTS){
        readline('F & beta structure -- return to continue ')
      } else {
        dev.off()
      } 
    }
  }
  #################################### cluster Emat
  
  graphics.off()
  
  if(!is.null(ematrix)){
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterGridE.pdf') ) # start plot
    
    mat1 <- .cov2Cor( ematrix )
    main1 <- expression(paste('Species ',hat(E)))
    opt <- list(mainLeft=main1, leftClus=T, leftLab=T, 
                colCode1 = specColor[notOther], rowCode = specColor[notOther],
                topLab1=T,ncluster = ncluster,
                lower1 = T, diag1 = F,horiz1=clusterIndex[,'E'])
    
    .clusterWithGrid(mat1, mat2=NULL, expand=1, opt)
    
    if(!SAVEPLOTS){
      readline('E: model-based response to X -- return to continue ')
    } else {
      dev.off()
    }
    
    ################# resid and Egrid
    
    graphics.off()
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'gridR_E.pdf') ) # start plot
    
    dcor <- .cov2Cor(covy)
    dcor[is.na(dcor)] <- 0
    
    mat1 <- dcor     
    mat2 <- .cov2Cor( ematrix[rownames(dcor),rownames(dcor)] )
    
    main1 <- expression(paste('Ordered by error ',hat(R)))
    main2 <- expression(paste('Response ',hat(E)))
    opt <- list(mainLeft='Species', main1=main1, main2 = main2,
                leftClus=T, leftLab=T, rowCode = specColor[notOther],
                topLab1 = T, topLab2 = T,rightLab=F,ncluster = ncluster,
                lower1 = T, diag1 = F,lower2 = T, diag2 = T)
    .clusterWithGrid(mat1, mat2, expand=1, opt)
    
    if(!SAVEPLOTS){
      readline('comparison R vs E -- return to continue ')
    } else {
      dev.off()
    }
    
    ################# data vs E grid
    
    graphics.off()
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'gridY_E.pdf') ) # start plot
    
    ytmp <- jitter(y[,mor],1e-10)
    cory <- cor(ytmp)
    
    mat1 <- cory
    mat2 <- ematrix[rownames(cory),rownames(cory)]
    main1 <- 'Ordered by data, cor(Y)'
    main2 <- expression(paste('Response ',hat(E)))
    topLab1 <- topLab2 <- F
    if(S < 30)topLab1 <- topLab2 <- T
    
    
    opt <- list(mainLeft='Species', main1=main1, main2 = main2,
                leftClus=T, leftLab=T, lower1 = T, diag1 = F, rowCode = specColor[notOther],
                topLab1 = topLab1, topLab2 = topLab2,ncluster = ncluster,
                lower2 = T, diag2 = T, sameOrder = T)
    .clusterWithGrid(mat1, mat2=mat2, expand=1, opt )
    
    if(!SAVEPLOTS){
      readline('raw data vs E -- return to continue ')
    } else {
      dev.off()
    }
  }
  
  #################### beta grid
  
  if(is.null(output$parameters$betaStandXWmu)){
    BETAGRID <- FALSE
  }else{
    if( nrow(output$parameters$betaStandXWmu) > 2 &
        ncol(output$parameters$betaStandXWmu) > 1)BETAGRID <- TRUE
  }
  
  if( BETAGRID ){
    
    graphics.off()
    
    mat1 <- .cov2Cor( output$parameters$ematrix[notOther,notOther] )
    mat2 <- t(output$parameters$betaStandXWmu)
    
    if( 'factorBeta' %in% names(inputs) & !FACNAMES){
      fcnames <- names( inputs$factorBeta$factorList )
      for(m in 1:length(fcnames)){
        colnames(mat2) <- .replaceString( colnames( mat2 ), fcnames[m], '' )
        rownames(mat2) <- .replaceString( rownames( mat2 ), fcnames[m], '' )
      }
    }
    
    
    if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterGridB.pdf') ) # start plot
    
    main1 <- expression(paste('Species ',hat(E)))
    main2 <- expression(paste(hat(B),' by predictor'))
    topLab1 <- F
    if(S < 30)topLab1 <- T
    
    ee <- ncol(mat1)/ncol(mat2)
    ee <- max(c(ee,.8))
    ee <- min(c(ee, 1.2))
    opt <- list(mainLeft=main1, main1=main1, main2 = main2,
                topClus1=T, topClus2=T, topLab1 = topLab1, topLab2=T,
                leftLab=T,lower1 = T, diag1 = F, ncluster = ncluster,
                colCode1 = specColor[notOther], rowCode = specColor[notOther],
                vert1=clusterIndex[,'E'], horiz2=clusterIndex[,'E'])
    .clusterWithGrid(mat1, mat2, expand=ee, opt)
    
    if(!SAVEPLOTS){
      readline('beta ordered by response to X -- return to continue ')
    } else {
      dev.off()
    }
    
    ################## random groups
    
    if(RANDOM){
      
      graphics.off()
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'randGroups.pdf') ) # start plot
      G <- ncol(randByGroup)
      
      mat1 <- randGroupVarMu[notOther,notOther]
      mat1 <- .cov2Cor(mat1)
      diag(mat1) <- 0
      mat2 <- randByGroup[notOther,] # + matrix(betaMu[1,notOther],length(notOther),G, byrow=T)
      main1 <- expression(paste('Species '))
      main2 <- expression('Group')
      topLab1 <- F
      if(S < 30)topLab1 <- T
      
      ee <- ncol(mat1)/ncol(mat2)
      ee <- max(c(ee,1))
      ee <- min(c(ee, 1.2))
      opt <- list(mainLeft=main1, main1=main1, main2 = main2,leftClus=T, 
                  topClus1=F, topClus2=T, topLab1 = topLab1, topLab2=T,
                  leftLab=T, lower1 = T, diag1 = F, 
                  colCode1 = specColor[notOther])
      .clusterWithGrid(mat1, mat2, expand=ee, opt)
      
      if(!SAVEPLOTS){
        readline('random groups correlation, coeffs -- return to continue ')
      } else {
        dev.off()
      }
    }
      
    ###################### Time grid
    if(TIME){
      
      graphics.off()
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterTime.pdf') ) 
      
      mat1 <- alphaMu[notOther,notOther]
      lam  <- rhoStandXmu[,notOther]
      mat2 <- t(lam)
      colnames(mat2)[1] <- 'rho'
      main1 <- expression(paste(hat(alpha),' from'))
      side1 <- expression(paste(hat(alpha),' to'))
      main2 <- expression(hat(rho))
      mat1[is.na(mat1)] <- 0
      mat2[is.na(mat2)] <- 0
      
      topLab1 <- F
      if(S < 30)topLab1 <- T
      
      ee <- ncol(mat1)/(ncol(mat1) + ncol(mat2) )
      slim1 <- range(mat1)
      if(slim1[2] == 0)slim1[2] <- .0001
      opt <- list(mainLeft=side1, main1=main1, main2 = main2,
                  ncluster = ncluster,
                  topClus1=F, topClus2=F, topLab1 = topLab1, 
                  topLab2=T, 
                  leftLab = T, rowCode = specColor[notOther],
                  rowOrder = c(1:S)[notOther], colOrder1 = c(1:S)[notOther], 
                  colOrder2 = 1:ncol(mat2), slim1 = slim1,
                  colCode1 = specColor[notOther], lower1 = F, diag1 = F)
      
      .clusterWithGrid(mat1, mat2, expand=ee, opt)
      
      if(!SAVEPLOTS){
        readline('alpha, rho -- return to continue ')
      } else {
        dev.off()
      }
      
      graphics.off()
      
      if(SAVEPLOTS)pdf( file=.outFile(outFolder,'clusterGridRho.pdf') ) # start plot
      
      mat1 <- ematrix
      main1 <- expression(paste('Species ',hat(E)))
      main2 <- expression(paste(hat(Rho),' by predictor'))
      topLab1 <- F
      if(S < 40)topLab1 <- T
      
   #   ee <- ncol(mat1)/(ncol(mat1) + ncol(mat2) )
      ee <- max(ee,.05)
      opt <- list(mainLeft=main1, main1=main1, main2 = main2,
                  colOrder2 = 1:ncol(mat2), ncluster = ncluster,
                  topClus1=T, topClus2=T, topLab1 = topLab1, topLab2=T,
                  colCode1 = specColor[notOther], lower1 = T, diag1 = F)
      #                vert1=clusterIndex[,'E'], horiz2=clusterIndex[,'E'])
      .clusterWithGrid(mat1, mat2, expand=ee, opt)
      
      if(!SAVEPLOTS){
        readline('Ematrix and rho -- return to continue ')
      } else {
        dev.off()
      }
    }
    
    if(TRAITS){
      
      betaTraitXMu <- output$parameters$betaTraitXWmu
        
      if(nrow(betaTraitXMu) > 3){
        
        bb <- betaTraitXMu[-1,]
        ord <- order(colSums(abs(bb)),decreasing=T)
        bb  <- bb[,ord]
        bl  <- bb[,ord]
        bh  <- bb[,ord]
        ror <- order(rowSums(abs(bb)),decreasing=T)
        bb  <- bb[ror,]
        bl  <- bl[ror,]
        bh  <- bh[ror,]
        
        white <- which(bl < 0 & bh > 0,arr.ind=T)
        
        makeColor <- list('white' = white )
        
        if(SAVEPLOTS)pdf( file=.outFile(outFolder,'gridTraitB.pdf') ) 
        
        plotScale <- max(c(10,c(S,Q)/10))
        
        par(mfrow=c(1,1), bty='n', oma=c(1,1,1,1), 
            mar=c(5,4,4,2), tcl= tcl, mgp=mgp)
        
        ht <- nrow(bb)/ncol(bb)*width
        
        opt <- list(mainLeft='', main1='', main2 = '',
                    topClus1=T, topClus2=T, topLab1 = T, topLab2=F,
                    leftClus=T, 
                    leftLab=T, ncluster = ncluster,
                    colCode1 = traitColor)
        .clusterWithGrid(mat1=betaTraitXMu[-1,], mat2=NULL, expand=1, opt)
        
        if(!SAVEPLOTS){
          readline('trait beta -- return to continue ')
        } else {
          dev.off()
        }
      }
    }
  }
  
  all <- list(fit = fit, ematrix = ematrix,
              eComs = eComs, ncluster = ncluster,
              clusterIndex = clusterIndex, clusterOrder = clusterOrder,
              eVecs = eVecs, eValues = eValues) 
  all <- all[ order(names(all)) ]
  invisible(all)
}



buildFullEffort <- function(ynames, columns, values){
  
  # full effMat from effort$values, which can be a vector or a partial matrix
  
  S <- length(ynames)
  n <- length(values)
  if( is.matrix(values) )n <- nrow(values)
  
  effMat <- matrix(1, n, S)
  colnames(effMat) <- ynames
  effMat[ ,ynames[columns] ] <- values
  
  list( columns = 1:S, values = effMat )
}

toConsole <- function( message, object = NULL, verbose = T ){
  
  if( !verbose )return()
  
  m <- paste('\n', message, '\n', sep='' )
  if( !is.null(object) )m <- paste('\n', message, ':\n', sep='' )
  cat(m)
  
  if( is.null(object) )return()
  print( object )
  cat('\n\n')
}
    
.gjamPrediction <- function(output, newdata, y2plot, PLOT, ylim, FULL, 
                            verbose = FALSE){
  
  if( is.null(newdata) ){  # if no new data, just extract predictions
    
    if(PLOT){
      
      y2plot <- .cleanNames(y2plot)
      
      y1 <- output$inputs$y
      y2 <- output$prediction$ypredMu
      if(!is.null(y2plot)){
        y1 <- y1[,y2plot]
        y2 <- y2[,y2plot]
      }
      
      tmp <- .bins4data(y1)
      breaks <- tmp$breaks
      bins   <- tmp$bins
      nbin   <- tmp$nbin
      
      if(length(bins) > 0){
        breaks <- bins
        nPerBin <- NULL
      }
      
      opt <- list(nPerBin = NULL, breaks=breaks, ylimit = range(y2, na.rm=T),
                  fill='lightblue', box.col='darkblue', POINTS=F)
      
      .plotObsPred(y1, y2, opt = opt)
      abline(0,1,lwd=4,col='white')
      abline(0,1,lwd=2,col='grey',lty=2)
    }
    return(  list( ypredMu = output$modelSummary$ypredMu, 
                   ypredSe = output$modelSummary$ypredSd ) )
  }
  
  if( is.data.frame(newdata) )stop('newdata is a data.frame, must be a named list')
  
  xdata   <- xnew   <- ydataCond <- interBeta <- groupRandEff <- NULL
  tiny    <- 1e-10
  effMat  <- wHold  <- phiHold <- ploHold <- sampleWhold <- NULL
  STAND   <- COND    <- RANDOM  <- NEWX <- XCOND <- FALSE
  cindex <- NULL
  groupRandEff <- 0
  TRAITS <- SAMEY <- FALSE
  effortSource <- 'output'
  holdoutN <- 0
  holdoutIndex <- NULL
  
  ng     <- output$modelList$ng
  burnin <- output$modelList$burnin
  randByGroupMu  <- output$parameters$randByGroupMu  # S by G random groups, mean
  randByGroupSe  <- output$parameters$randByGroupSe  # SE
  groupIndex     <- output$parameters$groupIndex     # group index
  rndEffMu       <- output$parameters$rndEffMu       # n by S from dimension reduction
  rndEffSe       <- output$parameters$rndEffSe       # SE
  ngroup         <- ncol(randByGroupMu)
  if(!is.null(randByGroupMu))RANDOM <- TRUE
  
  Q <- length(output$inputs$xnames)
  n <- nrow(output$inputs$y)
  y <- yp <- output$inputs$y
  x <- output$inputs$xStand
  S <- SO <- S1 <- ncol(y)
  xnames <- colnames(x)
  ynames <- colnames(y)
  notOther <- output$inputs$notOther
  other    <- output$inputs$other
  SO       <- length(notOther)
  otherpar <- output$modelList$reductList$otherpar
  censor   <- output$modelList$censor
  xdata    <- output$inputs$xdata
  effort   <- output$modelList$effort
  
  notStandard <- output$modelList$notStandard
  
  nsim <- 500
  if( 'nsim' %in% names(newdata) )nsim <- newdata$nsim
  if( 'xdata' %in% names(newdata) )NEWX <- T
  if( 'effort' %in% names(newdata))effort <- newdata$effort
  if( 'ydataCond' %in% names(newdata))COND <- T
  if( 'xdata' %in% names(newdata) & 'ydataCond' %in% names(newdata) )XCOND <- T
  if( 'SAMEY' %in% names(newdata) )SAMEY <- newdata$SAMEY  # if REDUCT, use fitted REs
  if( 'TRAITS' %in% names(output$modelList) )TRAITS <- output$modelList$TRAITS
  

  inSamp <- 1:n
  
  REDUCT <- output$modelList$REDUCT
  SAMEX  <- F # marginalize dim red random effects unless identical xdata
  sigmaerror <- NULL
  if(REDUCT){
    otherpar <- output$modelList$reductList$otherpar
    N  <- otherpar$N
    r  <- otherpar$r
    rndEff <- y*0
    sigmaerror <- otherpar$sigmaerror
    if( !NEWX )SAMEX <- T
    
    if(COND)stop('conditional prediction not currently implemented with dimension reduction' )
  }
  cuts <- output$parameters$cutMu
  if(!is.null(cuts))cuts <- cbind(-Inf,0,cuts,Inf)
  
  nfact      <- output$inputs$factorBeta$nfact
  isFactor   <- output$inputs$factorBeta$isFactor
  factorList <- output$inputs$factorBeta$factorList
  contrasts  <- output$inputs$factorBeta$contrast
  formula    <- output$modelList$formula
  xscale     <- output$inputs$standX
  if(is.matrix(xscale))  xscale <- t(xscale)
  facNames   <- names(factorList)
  facLevels <- unlist( factorList )   # needed to remove from standardized vars
  
  typeNames <- output$modelList$typeNames
  tmp       <- .gjamGetTypes(typeNames)
  typeFull  <- tmp$typeFull
  typeCols  <- tmp$typeCols
  allTypes  <- unique(typeCols)
  typeCode  <- tmp$TYPES[typeCols]
  FCgroups  <- attr(typeNames,'FCgroups')
  CCgroups  <- attr(typeNames,'CCgroups')
  CATgroups <- attr(typeNames,'CATgroups')
  condCols  <- numeric(0)
  corCols   <- which( typeNames %in% c('PA','OC','CAT') )
  notCorCols <- 1:S
  
  standRows  <- output$inputs$standRows
  standX     <- output$inputs$standX
  
  ig <- grep(':', names(standRows))
  if(length(ig) > 0)standRows <- standRows[-ig]
  
  ig <- grep(':', rownames(standX))
  if(length(ig) > 0)standX <- standX[ -ig, ]
  
  
  #factors are not standardized
  if(length(factorList) > 0){
    standRows  <- standRows[ !names(standRows) %in% facLevels ]
    standX     <- standX[ drop=F, !rownames(standX) %in% facLevels, ]
  }
  xmu        <- standX[,1]
  xsd        <- standX[,2]
  intMat     <- interBeta$intMat
  
  nx <- n

  if( !is.null(effort) ){
    effort <- buildFullEffort( ynames, effort$columns, effort$values)
    effMat <- effort$values
    effortSource <- 'newdata'
  }
  
  if( NEWX ){
    
    xnew <- newdata$xdata
    nx   <- n <- nrow(xnew)
    colnames(xnew) <- .cleanNames(colnames(xnew))
    
 #   wna <- which(is.na(xnew),arr.ind=T)
 #   if(length(wna) > 0)
 #     stop('cannot have NA in prediction grid newdata$xdata')
    
    if( 'effort' %in% names(newdata) ){
      effort <- buildFullEffort( ynames, newdata$effort$columns, newdata$effort$values)
      effortSource <- 'newdata'
      toConsole( 'effort taken from newdata', verbose )
    }else{
      effort <- buildFullEffort( ynames, 1:S, rep(1, nx) )
      effortSource <- 'none'
      if('DA' %in% typeNames)toConsole( 'Note: no effort provided, assumed = 1' , verbose = verbose)
    }
    effMat <- effort$values
  }
  
  ymaxData <- apply( output$inputs$y, 2, max )

  # check factors for random effects
  
  if( RANDOM ){
    
    if( NEWX ){
      
      # random groups, not all may be fitted
      rname      <- output$modelList$random       
      randGroupName <- as.character( xnew[,rname] )
      groupIndexNew <- which( !randGroupName %in% colnames(randByGroupMu) )
      groupIndex <- match( randGroupName, colnames(randByGroupMu) )
      
      newGroups <- NULL
      
      if( length(groupIndexNew) > 0 ){
        
        newGroups <- unique( groupIndex[groupIndexNew] )
        ngroupNew <- length(newGroups)
        toConsole( 'New random group(s) not in fitted data', newGroups, verbose )

        newMu <- matrix( 0, S, length(newGroups) )
        colnames(newMu) <- newGroups
        randByGroupMu <- cbind( randByGroupMu, newMu )
        avm   <- output$parameters$randGroupVarMu  # randEff covariance
        avs   <- output$parameters$randGroupVarSe
        lt    <- lower.tri(avm, diag = T)
        wrand <- which(lt, arr.ind=T)
        avg   <- matrix(0, S, S)
        
        rse <- sqrt( diag(avm) )
        newMu[1:length(newMu)] <- rse
        randByGroupSe <- cbind( randByGroupSe, newMu )
        ngroup <- ncol(randByGroupMu)
      }
      
      fnow <- names( which( sapply( output$inputs$xdata, is.factor ) ) )
      fnew <- names( which( sapply( xnew, is.factor ) ) )
      fnow <- fnow[ fnow %in% colnames(xnew) ]
      
      ww <- which( !fnow %in% fnew )
      if(length(ww) > 0)for(k in ww){ xnew[,fnow[k]] <- as.factor( xnew[,fnow[k]] ) }
      
      if( identical( output$inputs$xdata, xnew ) ){
        SAMEX <- T                                       # predict with random effects
        toConsole( 'Predict same X', verbose = verbose )
      }else{
        toConsole( 'Predict different X', verbose = verbose )
      }
      
    }else{   # if !SAMEX, marginalize random effects variance from dimension reduction
      groupIndex <- output$parameters$groupIndex
    }
    if(is.null(newGroups))toConsole( 'Use fitted random effects', verbose = verbose )
  }
  
  if( !NEWX & RANDOM )SAMEX <- T                             
  
  if( NEWX | XCOND ){   ################ out-of-sample
    
    holdoutN <- nx
    holdoutIndex <- 1:nx
    
    if(REDUCT){
      if(SAMEY){
        cat("\nUsing fitted RE from dimension reduction\n")
      }else{
        cat("\nRandom effects generated by dimension reduction are marginalized")
        cat(" here, unlike in function gjam where they are used directly for")
        cat(" prediction. With dimension reduction, predictions here will be")
        cat(" noisier than from gjam\n")
      }
    }
    
    ydataCond <- NULL
    
    if( nfact > 0 ){
      
      for(j in 1:nfact){
        
        nf <- names(factorList)[j]
        wf <- which(names(xnew) == nf)
        wo <- which(names(output$xnew) == nf)
        wc <- which(names(contrasts) == names(factorList)[j])
        cc <- contrasts[[wc]]
        xnew[[wf]] <- factor( xnew[[wf]], levels = rownames(cc) )
        attr(xnew[[wf]],'contrasts') <- cc
      }
    }
    
    yp <- matrix(0,nx,S)
    colnames(yp) <- ynames
    
    # standardize xnew
    tmp <- .getStandX(formula, xu = xnew, standRows, xmu = xmu, 
                      xsd = xsd, verbose = verbose )
    xnew <- tmp$xdataStand
    u2s  <- tmp$U2S
    if( !attr(u2s,'valid') )toConsole( 'Could not solve for unstandardized u2s for xnew', verbose = verbose )
    
    tmp <- .gjamXY(formula, xnew, yp, typeNames, 
                   notStandard = names(xnew), checkX = F, xscale = xscale,
                   verbose)
    x    <- tmp$x                       # standardized with original mean/var
    
    beta <- output$parameters$betaStandXmu
    beta[ is.na(beta) ] <- 0
    if( is.null(beta) ){
      beta <- output$parameters$betaMu
      STAND <- FALSE
    }
    
    w  <- x%*%beta  

    if( length(corCols) > 0 ){
      sg    <- output$parameters$sigMu
      alpha <- .sqrtMatrix( beta, sg, DIVIDE = T )
      w[,corCols] <- x%*%alpha[,corCols]
    }
    yp <- w*effMat
    
    
    wca <- which(typeNames == 'CA')
    if(length(wca) > 0){
      yp[,wca][yp[,wca] < 0] <- 0
    }
    
    wda <- which(typeNames == 'DA')
    if(length(wda) > 0){
      yp[,wda] <- round(yp[,wda],0)
      yp[,wda][yp[,wda] < 0] <- 0
    }
    
    ordCols <- which(typeNames == 'OC')
    if(length(ordCols) > 0){
      
      tmp   <- .gjamGetCuts(yp + 1, ordCols)
      cutLo <- tmp$cutLo
      cutHi <- tmp$cutHi
      
      for(k in ordCols){
        yp[,k] <- findInterval(yp[,k],cuts[k,]) - 1
      }
    }
    
    if( length(FCgroups) > 0 ){
      ntt <- max(FCgroups)
      for(i in 1:ntt){   
        wk      <- which( FCgroups == i )
        wo      <- which(wk %in% notOther)
        yp[,wk] <- .gjamCompW2Y(yp[,wk,drop=F], notOther=wo)$ww
      }
    }
    
    if( length(CCgroups) > 0 ){
  
      toConsole( 'For CC data total effort (count) is taken as 10000', verbose = verbose )
      
      ysum <- rep(10000,n)                   # CC use sum of 100
      ntt  <- max(CCgroups)
      
      y      <- output$inputs$y
      wFromY <- sweep( y, 1, rowSums(y, na.rm=T), '/')
      wFromY[ !is.finite(wFromY) ] <- 0
      wmax <- apply( wFromY, 2, max )
      wmat <- matrix( wmax, n, S, byrow = T )
      
      yp <- sweep( wmat, 1, rowSums(wmat, na.rm=T), '/')
      yp <- round( yp*10000 )
    }
    
    
    tmp <- .gjamSetup(typeNames, x, y = yp, breakList=NULL, holdoutN=NULL, 
                      holdoutIndex=NULL, censor=NULL, effort=effort) 
    w <- tmp$w; z <- tmp$z; yp <- tmp$y; other <- tmp$other
    plo <- tmp$plo; phi <- tmp$phi
    ordCols  <- tmp$ordCols; disCols <- tmp$disCols; compCols <- tmp$compCols 
    minOrd   <- tmp$minOrd;   maxOrd <- tmp$maxOrd;  censorCA <- tmp$censorCA
    censorDA <- tmp$censorDA;   censorCON <- tmp$censorCON;   ncut <- ncol(cuts)
    corCols  <- tmp$corCols
    if(length(corCols) > 0)notCorCols <- notCorCols[-corCols]
    catCols  <- which(attr(typeNames,'CATgroups') > 0)
    sampleW  <- tmp$sampleW*0 + 1
    
    byCol <- byRow <- F
    if(attr(sampleW,'type') == 'cols')byCol <- T
    if(attr(sampleW,'type') == 'rows')byRow <- T
    indexW <- attr(sampleW,'index')
    inSamp <- 1:n
    
    byCol <- byRow <- F
    if(attr(sampleW,'type') == 'cols')byCol <- T
    if(attr(sampleW,'type') == 'rows')byRow <- T
    indexW <- attr(sampleW,'index')
    
    cdex <- c(1:S)
  }
  
  
  if( COND | XCOND ){
    
    ydataCond <- newdata$ydataCond

    if( !is.data.frame(ydataCond) & !is.matrix(ydataCond) )stop( 'ydataCond must be a matrix with column names to match ydata' )
    if(is.data.frame(ydataCond))ydataCond <- as.matrix(ydataCond)
    
    colnames(ydataCond) <- .cleanNames(colnames(ydataCond))
    condNames <- colnames(ydataCond)
    
    if('other' %in% condNames){
      condNames <- condNames[condNames != 'other']
      ydataCond <- ydataCond[,condNames]
    }
    
    if( !XCOND )yp <- y
    
    condCols <- match(condNames, colnames(yp))
    yp[,condCols] <- as.matrix( ydataCond )
    
    # conditional columns that require w for discrete values
    condW   <- condCols[ typeNames[condCols] %in% c('CA','DA','PA','OC','CC') ]
    condCA  <- condCols[ typeNames[condCols] == 'CA' ]
    cdex    <- c(1:S)[-condCols]
    
  } ##############################
  
  
  tmp <- .gjamSetup(typeNames, x, yp, breakList=NULL, holdoutN=NULL, 
                    holdoutIndex=NULL,censor=NULL, effort=effort) 
  w <- tmp$w; z <- tmp$z; yp <- tmp$y; other <- tmp$other
  plo      <- tmp$plo; phi <- tmp$phi
  ordCols  <- tmp$ordCols; disCols <- tmp$disCols; compCols <- tmp$compCols 
  minOrd   <- tmp$minOrd;   maxOrd <- tmp$maxOrd;  censorCA <- tmp$censorCA
  cuts     <- tmp$cuts
  censorDA <- tmp$censorDA;   censorCON <- tmp$censorCON; ncut <- ncol(cuts)
  corCols  <- tmp$corCols
  if(length(corCols) > 0)notCorCols <- notCorCols[-corCols]
  catCols  <- which(attr(typeNames,'CATgroups') > 0)
  sampleW  <- tmp$sampleW
  sampleW[,-condCols] <- 1
  
  byCol <- byRow <- F
  if(attr(sampleW,'type') == 'cols')byCol <- T
  if(attr(sampleW,'type') == 'rows')byRow <- T
  indexW <- attr(sampleW,'index')
  
  yz <- y
  if( XCOND )yz <- yp  # if out-of-sample and conditional use yp for row sums
  
  if(length(other) > 0)cdex <- cdex[!cdex %in% other]
  S1   <- length(cdex)
  
  yg <- yp
  
  if(length(yp) < 10000 | FULL) FULL <- T
  
  if(FULL){
    ygibbs <- wgibbs <- matrix(0,nsim,length(yp))
  }
  
  # partition out-of-sample based on max ever obs for species
  pmax <- apply(output$inputs$y/output$modelList$effort$values,2,max) 
  
  CCsums <- CCmax <- numeric(0)
  if( !is.null(CCgroups) ){
    ncc    <- max(CCgroups)
    for(j in 1:ncc){                   # put max observed on (0,1) scale
      wjk    <- which(CCgroups == j)
      rs <- rowSums( output$inputs$y[,wjk] )
      ms <- output$inputs$y[,wjk]/rs
      ms <- apply(ms, 2, max, na.rm = T)#*10000
      CCmax <- append(CCmax, list( ms ) )
      CCsums <- append(CCsums, list( rs ) )
      pmax[ wjk ] <- ms
    }
  }
  
  pmax[ pmax < .1 & typeNames %in% c('DA','CA','PA','OC') ] <- .1
  
  ptmp <- 2*matrix(pmax,n,S,byrow=T)                 
  
  ptmp[,ordCols]  <- length(ordCols) + 10
  ptmp[,compCols] <- 1.2*ptmp[,compCols]
  ptmp[,compCols][ptmp[,compCols] > 1] <- 1
  ptmp[,catCols]  <- 10
  
  if( COND ){
    
    ncc <- sort(unique( c(condCols, other) ))
    
    ploCond <- -ptmp[,-ncc, drop = F]/2
    phiCond <- 5*ptmp[,-ncc, drop = F]
    colnames(ploCond) <- colnames(phiCond) <- colnames(y)[-ncc]
    
    plo[,-ncc] <- ploCond
    phi[,-ncc] <- phiCond
    
    # note: all are holdouts for newdata, no holdouts for COND
    
    holdoutN <- 0
    holdoutIndex <- NULL
    ploHold <- phiHold <- NULL
  }
  
  if( !COND & !XCOND & !SAMEX ){
    holdoutN <- n
    holdoutIndex <- c(1:n)
    plo <- -ptmp*.5
    phi <- 5*ptmp
    ploHold <- -ptmp*.5
    phiHold <- 5*ptmp
  }
  
  if( SAMEY ) holdoutN <- 0
  
  RD <- F                                # none or marginalize random effects into sigma
  if( (REDUCT & SAMEX) | SAMEY) RD <- T  # use fitted random effects from dimRed
    
  .updateW <- .wWrapper(REDUCT = RD, RANDOM, S, effMat, corCols, notCorCols, typeNames, 
                            typeFull, typeCols, 
                            allTypes, holdoutN, holdoutIndex, censor, 
                            censorCA, censorDA, censorCON, notOther, sampleW, 
                            byRow, byCol,
                            indexW, ploHold, phiHold, sampleWhold, inSamp)
  ypred  <- matrix(0,n,S)
  colnames(ypred) <- ynames
  ypred2 <- wcred <- wcred2 <- ypred
  
  if(TRAITS){
    specByTrait <- output$modelList$traitList$specByTrait
    specTrait <- specByTrait[colnames(y),]
    tnames    <- colnames(specTrait)
    M         <- ncol(specTrait)
    specTrait <- t(specTrait)
    traitTypes <- output$modelList$traitList$traitTypes
    tpred <- matrix(0, n, M)
    colnames(tpred) <- rownames(specTrait)
    tpred2 <- tpred
  }
  
  
  gvals  <- sample(burnin:ng,nsim,replace=T)
  
  pbar <- txtProgressBar(min=1,max=nsim,style=1)
  ig   <- 0
  
  corColC <- cdex[cdex %in% corCols]
  corColW <- which(cdex %in% corCols)
  
  ddex <- which(notOther %in% cdex)
  kdex <- c(1:S)[-ddex]
  pdex <- ddex[ typeNames[ddex] %in% c('CON','CA') ] # cond pred only continuous
  
  cutg <- cuts
  ncut <- ncol(cutg)
  
  ccols <- which(typeNames != 'CON')
  
  kg     <- 1
  
  rndEff <- 0
  
  prPresent <- w*0
  
  ############ E matrix
  emat <- matrix(0,S,S)
  colnames(emat) <- rownames(emat) <- ynames
  lo <- hi <- lm <- hm <- ess <- emat
  
  eCont <- output$inputs$factorBeta$eCont
  dCont <- output$inputs$factorBeta$dCont
  lCont <- output$inputs$factorBeta$lCont
  
  covE <- cov( x%*%dCont )  # note that x is standardized
  
  frow  <- NULL
  if(nfact > 0){
    frow <- rep(0,Q)
    for(j in 1:nfact){
      frow[ match(factorList[[j]], xnames) ] <- j
    }
  }

  q1 <- nrow(eCont)
  fnames   <- rownames(eCont)
  facList2 <- factorList
  if(nfact > 0){
    for(j in 1:nfact){
      wj <- which(names(xnew) == names(factorList)[j])
      facList2[[j]] <- levels(xnew[[wj]])
    }
  }
  notPA <- which(!typeNames == 'PA' & !typeNames == 'CON')
  notPA <- notPA[ !notPA %in% condCols ]
  
  tiny  <- 1e-5
  sampW <- 1 + w*0
  rows  <- 1:nrow(w)
  bg    <- output$parameters$betaStandXmu*0
  
  chainNames <- colnames( output$chains$bgibbs )
  dimnames   <- dimnames(bg)
  
  tt <- .multivarChainNames2matrix( chainNames, dimnames )
  bg <- tt$beta
  wB <- tt$wB
  
  for(g in gvals){ 
    
    bg[wB] <- output$chains$bgibbs[g,]  # standardized
    muw <- x%*%bg                                 
    
    if( REDUCT ){
      
      sigmaerror <- output$chains$sigErrGibbs[g]
      
      if( RD ){                                    # use fitted random effects for dim reduct
        rndEff <- rndEffMu + matrix( rnorm( n*S, 0, rndEffSe ), n, S )
        sg     <- diag(sigmaerror, S)
      }else{                                        # marginalize random effects
        rndEff <- 0
        Z  <- matrix(output$chains$sgibbs[g,],N,r)
        K  <- output$chains$kgibbs[g,]
        sg <- .expandSigma(sigmaerror, S, Z = Z, K, REDUCT = T)
      }
      if( COND ){   # needed for conditional distribution
        Z  <- matrix(output$chains$sgibbs[g,],N,r)
        K  <- output$chains$kgibbs[g,]
        sgcond <- .expandSigma(sigmaerror, S, Z = Z, K, REDUCT = T) 
      }
      
    } else {
      sg <- .expandSigma(output$chains$sgibbs[g,], S = S, REDUCT = F)
    }
    
    if( RANDOM ){
        randByGroup <- rnorm( length(randByGroupMu), randByGroupMu, randByGroupSe )
        randByGroup <- t( matrix( randByGroup, S, ngroup ) )
        rownames(randByGroup) <- colnames(randByGroupMu)
        groupRandEff <- randByGroup[groupIndex,]
      if( !is.null(newGroups) ){
        avg[ wrand ] <- rnorm(nrow(wrand), avm[wrand], avs[wrand])
        avg[ wrand[,c(2,1)] ] <- avg[ wrand ]
        groupRandEff[ groupIndexNew, ] <- rmvnormRcpp(length(groupIndexNew), 0, avg)   
      }
    }
    
    alpha <- .sqrtMatrix(bg,sg,DIVIDE=T)
    agg   <- .sqrtMatrix(bg[,notOther],sg[notOther,notOther],DIVIDE=T)  
    
    if(nfact > 0){
      agg <- lCont%*%agg    #standardized for x and cor scale for y
      for(k in 1:nfact){
        fk  <- factorList[[k]]
        mua <- colMeans(agg[drop=F,fk,])
        nl  <- length(fk)
        agg[fk,] <- agg[fk,] - matrix(mua,nl,SO,byrow=T)
      }
    } else {
      agg <- agg[drop=F,-1,]
    }
    
    egg         <- lCont%*%bg[,notOther]          #standardized for x, not cor for y
    
    if( 'OC' %in% typeCode ){
      cutg[,3:(ncut-1)] <- matrix( output$chains$cgibbs[g,], length(ordCols))
      tmp   <- .gjamGetCuts(yg + 1,ordCols)
      cutLo <- tmp$cutLo
      cutHi <- tmp$cutHi
      plo[,ordCols] <- cutg[cutLo]
      phi[,ordCols] <- cutg[cutHi]
    }
    
    tmp <- .updateW( rows=1:nrow(x), x, w, y = yp, bg, sg, alpha, cutg, plo, phi, 
                     rndEff=rndEff, groupRandEff, sigmaerror, wHold )
    w   <- tmp$w
    yg  <- tmp$yp  # predictions
    
    if( COND | XCOND ){
      
      if( length(ddex) > 0 ){  
        
        gre <- groupRandEff
        if(length(gre) > 1)gre <- groupRandEff[,notOther]
        
        tmp <- .conditionalMVN(w[,notOther], muw[,notOther] + gre, 
                               sg[notOther,notOther], cdex = ddex)  # conditioning on w
        muc <- tmp$mu
        sgp <- tmp$vr #+ tiny
        
        wd  <- which( ddex %in% corCols )
        if( length(wd) > 0 ){
          css <- .cov2Cor(sg)
          mus <- x%*%alpha
          wws <- .sqrtMatrix(w, sg, DIVIDE = T)
          tmp <- .conditionalMVN(wws, mus + groupRandEff, css, cdex = ddex, S)  # conditioning on w
          muk <- tmp$mu
          sgk <- tmp$vr
          muc[,wd] <- muk
          sgp[wd,wd] <- sgk
        }
        
        if( length(ddex) == 1 ){
          wex <- matrix( .tnorm(nrow(x), ploCond, phiCond, muc, sqrt(sgp[1])), ncol=1 )
        } else {
          
          lo <- ploCond
          hi <- phiCond
          avec <- muc
          avec[ muc < lo ] <- lo[ muc < lo ]
          avec[ muc > hi ] <- hi[ muc > hi ]
          
          wex <- .tnormMVNmatrix( avec = avec, muvec = muc, smat = sgp,
                                       lo=lo, hi=hi) 
        }
        yPredict <- yg
        yPredict[,ddex] <- wex
        
        
        groups <- NULL
        z <- w
        z[,ddex] <- wex
        
        for(k in allTypes){
          
          wk <- which(typeCols == k)
          nk <- length(wk)
          wo <- which(wk %in% notOther)
          wu <- which(typeCols[notOther] == k)
          wp <- z[, wk, drop=F]                
          yq <- yPredict[, wk, drop=F]
          
          if(typeFull[wk[1]] == 'countComp')groups <- CCgroups
          if(typeFull[wk[1]] == 'fracComp')groups  <- FCgroups
          if(typeFull[wk[1]] == 'categorical')groups <- CATgroups
          
          glist <- list(wo = wo, type = typeFull[wk[1]], yy = y[,wk,drop=F], 
                        wq = wp, yq = yq, cutg = cutg, 
                        censor = censor, censorCA = censorCA, 
                        censorDA = censorDA, censorCON  = censorCON, 
                        eff = effMat[,wk,drop=F], groups = groups, 
                        k = k, typeCols = typeCols, notOther = notOther, 
                        wk = wk, sampW = sampleW[,wk])
          tmp <- .gjamWLoopTypes( glist )
          yPredict[,wk] <- tmp[[2]]      # w to y scale
        }
        
     #     yPredict[,wk] <- .censorValues(censor, y, yPredict)[,wk]
        }
        yg[,ddex] <- yPredict[,ddex]
        muw[,pdex] <- muc
      
      
      yg[,condCols] <- as.matrix( ydataCond )
    }
    ####################
    
    if( length(ccols) > 0 ){  # all types except 'CON'
      mmm <- muw[,ccols]
      mmm[mmm < 0] <- 0
      muw[,ccols] <- mmm
    }
    
    yy <- yg
    
    if('PA' %in% typeNames){               # yg is probit(w)
      wpa <- which(typeNames == 'PA')
      yy[,wpa] <- round(yg[,wpa])
    }
    
    if( length(notPA) > 0 ){
      w0 <- which(yy[,notPA] <= 0)
      w1 <- which(yy[,notPA] > 0)
      yy[,notPA][w0] <- 0
      yy[,notPA][w1] <- 1
    }
    
    prPresent <- prPresent + yy
    
    ig <- ig + 1
    setTxtProgressBar(pbar,ig)
    
    ypred  <- ypred + yg
    ypred2 <- ypred2 + yg^2
    wcred  <- wcred + muw
    wcred2 <- wcred2 + muw^2
    
    ess[notOther,notOther]  <- .cov2Cor( t(agg)%*%covE%*%agg ) 
    emat[notOther,notOther] <- emat[notOther,notOther] + ess[notOther,notOther]
    
    if(FULL){
      ygibbs[kg,] <- as.vector(yg)
      wgibbs[kg,] <- as.vector(muw)
    }
    
    if(TRAITS){
      yw     <- yg
      yw[yw <= 0]   <- 0
      yw[is.na(yw)] <- 0
      yw     <- sweep(yw,1,rowSums(yw),'/')
      Ttrait <- .gjamPredictTraits(yw,specTrait, traitTypes)
      tpred  <- tpred + Ttrait
      tpred2 <- tpred2 + Ttrait^2
    }
      
    kg <- kg + 1
  } #####################################################
   
  prPresent <- prPresent/nsim
  
  ematrix  <- emat/nsim
  
  xf  <- NULL
  if(length(facNames) > 0){
    xf <- xdata[, facNames, drop=F]
  }
  xunstand <- try( .getUnstandX( formula, x, xdata, standRows  ), T )
  if( inherits(xunstand,'try-error') ){
    xunstand <- NULL
  }else{
    xunstand <- xunstand$xu
  }
  
  ms <- sums2meanSd( ypred, ypred2, nsim )
  yMu <- ms$mean
  yPe <- ms$sd
  
  ms <- sums2meanSd( wcred, wcred2, nsim )
  wMu <- ms$mean
  wSe <- ms$sd
  
  colnames(yMu) <- colnames(yPe) <- colnames(wMu) <- 
    colnames(wSe) <- ynames
  
  sdList <- list( yMu = yMu, yPe = yPe, wMu = wMu, wSe = wSe )
  
  if(TRAITS){
    ms <- sums2meanSd( tpred, tpred2, nsim )
    sdList$tMu <- ms$mean
    sdList$tSe <- ms$sd
  }
  
  
  piList <- NULL
  if(FULL){
    wLo <- matrix( apply(wgibbs,2,quantile,.05), n, S )
    wHi <- matrix( apply(wgibbs,2,quantile,.95), n, S )
    yLo <- matrix( apply(ygibbs,2,quantile,.05), n, S )
    yHi <- matrix( apply(ygibbs,2,quantile,.95), n, S )
    
    colnames(wLo) <- colnames(wHi) <- colnames(yLo) <- 
      colnames(yHi) <-  ynames
    piList <- list( wLo = wLo, wHi = wHi, yLo = yLo, yHi = yHi )
  }
    
  if(PLOT){
    
    oma <- c(0,0,0,0)
    mar <- c(4,4,2,1)
    tcl <- -0.5
    mgp <- c(3,1,0)
    
    par(oma = oma, mar = mar, tcl = tcl, mgp = mgp, bty='n')
    
    wy <- which(colnames(y) %in% y2plot & c(1:S) %in% notOther)
    t2plot <- typeNames[wy]
    allTypes <- unique(t2plot)
    
    mfrow <- .getPlotLayout(length(allTypes) + 1)
    par(mfrow=mfrow, bty='n', mar=c(1,2,3,1) )
    
    k   <- 0
    add <- F
    
    for(j in 1:length(allTypes)){
      
      wk <- which(typeNames == allTypes[j] & c(1:S) %in% notOther)
      ws <- colnames(y)[wk]
      wm <- which(colnames(yMu) %in% colnames(y)[wk])
      wk <- match(colnames(yMu)[wm],colnames(y))
      
      y1 <- y[,wk]
      if(min(y1) == max(y1))next
      y2 <- yMu[,wm]
      
      tmp <- .gjamPlotPars(type=allTypes[j],y1,y2)
      y1 <- tmp$y1; yp <- tmp$yp; nbin <- tmp$nbin; nPerBin <- tmp$nPerBin
      vlines <- tmp$vlines; xlimit <- tmp$xlimit; ylimit <- tmp$ylimit
      breaks <- tmp$breaks; wide <- tmp$wide; LOG <- tmp$LOG; POINTS <- F
      MEDIAN <- tmp$MEDIAN
      
      log <- ''
      if(LOG)log <- 'xy'
      
      if(LOG){
        wn <- which(y1 > 0 & yp > 0)
        y1 <- y1[wn]
        yp <- yp[wn]
      }
      
      tmp <- .bins4data(y1,nPerBin=nPerBin,breaks=breaks,LOG=LOG)
      breaks <- tmp$breaks
      bins   <- tmp$bins
      nbin   <- tmp$nbin
      
      if( !allTypes[j] %in% c('PA','CAT') ){
        ncc   <- max( c(100,max(y1)/20) )
        xy <- .gjamBaselineHist(y1,bins=bins,nclass=ncc)
        xy[2,] <- ylimit[1] + .8*xy[2,]*diff(ylimit)/max(xy[2,])
        plot(xy[1,],xy[2,],col='tan',type='s',lwd=2,xlim=xlimit,ylim=ylimit,
             xlab='Observed',ylab='Predicted')
        polygon(xy[1,],xy[2,],border='tan',col='wheat')
        
      } else {
        y11 <- mean(y1)
        y00 <- 1 - y11
        x11 <- c(-.07,-.07,.07,.07,.93,.93,1.07,1.07,-.07)
        y11 <- c(0,y00,y00,0,0,y11,y11,0,0)
        plot(x11,y11,col='tan',type='s',lwd=2,xlim=xlimit,ylim=ylimit,
             xlab='Observed',ylab='Predicted')
        polygon(x11,y11,border='tan',col='wheat')
      }
      abline(0,1,lty=2,lwd=3,col='brown')
      abline(h = mean(y1),lty=2,lwd=3,col='tan')
      
      add <- T
      
      
      opt <- list(xlabel='Observed',ylabel='Predicted',nbin=nbin, 
                  nPerBin=nPerBin, xlimit=xlimit,ylimit=ylimit,
                  breaks=breaks, wide=wide, LOG=LOG, fill='lightblue', 
                  box.col='darkblue',POINTS=F, MEDIAN=MEDIAN, add=add)
      
      .plotObsPred(y1, y2, opt = opt)
      
      tt <- allTypes[j]
      if(length(ws) == 1)tt <- paste(ws,tt,sep='-')
      
      lab <- paste(letters[j],') ',tt, sep='')
      .plotLabel( lab,above=T )
    }
    
    yp  <- colMeans(yMu)
    wy  <- match(colnames(yMu),colnames(y))
    
    
    opt <- list(xlabel='Observed', xlimit=NULL, ylimit=NULL,
                breaks=breaks, wide=wide, LOG=LOG, fill='lightblue', 
                box.col='darkblue', POINTS=T, ptcol='darkblue')
    .plotObsPred( colMeans(y[,wy]),yp, opt = opt)
    
    abline(0, 1,lty=2,lwd=3,col='brown')
    abline(h = mean(y1),lty=2,lwd=3,col='tan')
    .plotLabel( paste(letters[j+1],') By Species',sep=''),above=T )
    
  }
  
  xb <- xunstand
  if(is.null(xb))xb <- x
    
  bk <- list( x = xb, sdList = sdList, piList = piList, prPresent = prPresent,
               ematrix = ematrix, effortSource = effortSource)
  if(FULL)bk <- append( bk, list(ychains = ygibbs) )
  bk
}

   
.updateBetaTime <- function(X, Y, sig, rows, pattern, lo=NULL, hi=NULL){
  
  SS <- ncol(Y)
  B  <- t(lo)*0
  tiny <- 1e-5
  
  QX  <- ncol(X)
  XX <- crossprod(X)
  
  omega <- sig*solveRcpp(XX)
  muB   <- t(omega%*%crossprod((1/sig)*X, Y))
  
  for(k in 1:nrow(rows)){
    krow <- rows[k,]
    krow <- krow[is.finite(krow)]
    notk <- c(1:QX)[-krow]
    if(length(notk) == 1){
      M1 <- omega[krow,notk, drop=F]/omega[notk,notk]
    }else{
      OI <- try( solveRcpp(omega[notk,notk]), T)
      if( inherits(OI,'try-error') ){
        OI <- diag(1/diag(omega[notk,notk]))
      }
      M1 <- omega[krow,notk, drop=F]%*%OI
    }
    pk  <- pattern[k,]
    pk  <- pk[is.finite(pk)]
    muk <- muB[pk, krow, drop=F] - muB[pk,notk]%*%t(M1)
    Mk  <- omega[krow,krow] - M1%*%omega[notk,krow]
    
    if(is.null(lo)){
      if(length(Mk) == 1){
        B[pk,krow] <- rnorm(length(pk),muk,sqrt(Mk))
      }else{
        B[pk,krow] <- rmvnormRcpp( length(pk), rep(0,length(krow)), Mk) + muk
      }
    } else { 
      if(length(Mk) == 1){
        B[pk,krow] <- .tnorm(length(pk),lo[krow,pk],hi[krow,pk],muk,sqrt(Mk))
      } else {
        ll <- t(lo)[pk,krow,drop=F]
        hh <- t(hi)[pk,krow,drop=F]
        test <- try( .tnormMVNmatrix( avec=muk, muvec=muk, smat=Mk,
                                          lo=ll, hi=hh), T)
        if( inherits(test,'try-error') ){
          mm <- diag(Mk)
          mm[mm < tiny] <- tiny
          test <- .tnorm(length(ll),ll,hh,muk,sqrt(mm))
        }
        B[pk,krow] <- test
      }
    }
  }
  t(B)
}

.updateTheta <- function(w,tg,cutLo,cutHi,ordCols,holdoutN,
                             holdoutIndex,minOrd,maxOrd){
  
  word <- w[,ordCols,drop=F]
  ncut <- ncol(tg)
  nr   <- nrow(tg)
  nc   <- ncut - 1
  n    <- nrow(w)
  nk   <- length(ordCols)
  tiny <- 1e-5
  summat <- matrix(0, nr, ncut)
  
  c1 <- cutLo[,1]
  c2 <- cutLo[,2]
  c3 <- cutHi[,1]
  c4 <- cutHi[,2]
  
  if(holdoutN > 0){
    word <- word[-holdoutIndex,]
    ss   <- seq(0,(nk-1)*n,by=n)
    wh <- as.vector( outer(holdoutIndex,ss,'+') )
    c1 <- c1[-wh]
    c2 <- c2[-wh]
    c3 <- c3[-wh]
    c4 <- c4[-wh]
  }
  
  cmin <- .byGJAM(as.vector(word),c1,c2, summat=summat, fun='min')
  cmax <- .byGJAM(as.vector(word),c1,c2, summat=summat, fun='max')
  cmin <- cbind(cmin, Inf)
  cmax <- cbind(cmax, -Inf)
  
  maxw <- 2*max(w, na.rm=T) 
  
  cmin[,2] <- cmax[,1] <- 0
  
  cmin[ cbind(1:nr,maxOrd+1) ] <- cmax[ cbind(1:nr,maxOrd) ] + .1
  cmax[ cbind(1:nr,maxOrd+1) ] <-  cmin[ cbind(1:nr,maxOrd+1) ] + .1
 
  
  
  icol <- 2:ncut
  
  clo <- cmax[drop=F,,1:(ncut-1)]
  chi <- cmin[drop=F,,icol]
  
  rowMax <- apply(cmax, 1, max, na.rm=T)
  
  ni <- ncol(clo) 
  
  for(i in 2:ni){
    wi <- which(  !is.finite(clo[,i]))# & maxOrd > i)
    if(length(wi) > 0)clo[wi,i] <- chi[wi,i-1] + tiny
    
    wi <- which( clo[,i] < chi[,i-1])# & maxOrd > i )
    if(length(wi) > 0)clo[wi,i] <- clo[wi,i-1] + tiny
    
    wi <- which(!is.finite(chi[,i]) & maxOrd == i)
    if(length(wi) > 0)chi[wi,i] <- maxw
    
    wi <- which(!is.finite(chi[,i]) & maxOrd > i)
    if(length(wi) > 0){
      chi[wi,i] <- clo[wi,i] + tiny
    }
    
    wi <- which(chi[,i] < clo[,i])
    if(length(wi) > 0)chi[wi,i] <- clo[wi,i] + tiny
    
  }
  
  wi  <- which(is.nan(tg),arr.ind=T)
  if(length(wi) > 0)tg[wi] <- clo[wi] + tiny
  cmu <- tg[drop=F,,icol]
  ww  <- which(is.finite(cmu))
  
  tg[,icol][ww] <- .tnorm(length(ww), clo[ww], chi[ww], cmu[ww], .1)
  tg[,1] <- -10
  
  tg
}

.censorValues <- function(censor,y,yp){
  
  mm  <- length(censor)
  if(mm == 0)return(yp)
  
  if(mm > 0){
    for(m in 1:mm){
      wc  <- censor[[m]]$columns
      nc  <- ncol( censor[[m]]$partition )
      ym  <- yp[,wc,drop=F]
      cp  <- censor[[m]]$partition
      for(k in 1:nc){
        wlo <- which( ym >  cp[2,k] & ym <  cp[3,k])
        ym[wlo] <- cp[1,k]
      }
      yp[,wc] <- ym
    }
  }
  yp
}

.gjamWLoopTypes <- function( glist ){
  
  # change yp from w scale to y scale
  
  wo <- type <- yy <- wq <- yq <- cutg <- censor <- 
  censorCA <- censorDA <- censorCON <- eff <- groups <- k  <- 
  typeCols <- notOther <- wk <- sampW <- NULL
  
  for(k in 1:length(glist))assign( names(glist)[k], glist[[k]] )
  
  if( type == 'continuous' ){
 #   yy[sampW == 1] <- yq[sampW == 1]
    return( list(wq, yq) )   # w = y
  }
  
  nk  <- ncol(wq)
  wkk <- c(1:nk)
  n  <- nrow(wq)
  
  if( type == 'ordinal' ){
    w2y <- wq
    for(s in 1:nk){
      yq[,s]  <- findInterval(yq[,s],cutg[s,]) - 1
  #    w2y[,s] <- findInterval(wq[,s],cutg[s,]) - 1
    }
      
    return( list(wq, yq) )
  }
  
  if( type == 'presenceAbsence' ){
    yq <- pnorm(yq)                      # probit
    return( list(wq, yq) )
  }
  
  if( type == 'contAbun' ){
   
    yq[yq < 0]   <- 0    
    return( list(wq,yq) )
  }
  
  if( type == 'discAbun' ){
    
    yq <- yq*eff
    yq[yq < 0] <- 0
    if( length(censorDA) > 0 ) yq[-censorDA] <- yq[-censorDA]
    
    return( list( wq, yq) )
  }
  
  if( type == 'categorical' ){ ## only prediction
    
    ntt <- max( groups )
    w2y <- yq
    
    for(i in 1:ntt){  
      
      if(ntt == 1){
        wki <- wkk
      } else {
        wki <- which( groups == i )
      }
      nki  <- length(wki)
      wko  <- wki
      wmax <- apply( yq[,wko],1, which.max) 
      yq[,wki] <- 0
      yq[,wki][ cbind(1:n,wmax) ] <- 1
      
      wmax <- apply( wq[,wko],1, which.max) 
      w2y[,wki] <- 0
      w2y[,wki][ cbind(1:n,wmax) ] <- 1
      
    }
    return( list(wq, w2y) )
  }
  
  if( type == 'countComp' ){  ##  w and y 
    
    ntt <- max( groups )
    ww  <- wq  
  #  ww[ww < 0] <- 0     
    yq[yq < 0] <- 0
    
    for(i in 1:ntt){  ## normalize w and y 
      
      if(ntt == 1){
        wki <- wkk
      } else {
        wki <- which( groups == i )
      }
      
      io <- which(wki %in% wo)
      wc <- .gjamCompW2Y(ww[,wki,drop=F], notOther=io)$ww
      ww[,wki][wq[,wki] > 0] <- wc[wq[,wki] > 0]
      
      yq[,wki] <- .gjamCompW2Y(yq[,wki,drop=F],notOther=io)$ww
      ysum     <- rowSums(yy[,wki,drop=F])
      yq[,wki] <- round( sweep(yq[,wki,drop=F],1,ysum,'*'), 0) 
    }
    return( list(ww,yq) )
  }
  
  ## fracComp: w and y 
  
  ntt <- max( groups )
  
  wy     <- which(yq > 0)  
  wq[wy] <- yq[wy]     
  yq[yq < 0] <- 0
  
  for(i in 1:ntt){  ## normalize w and y 
    
    if(ntt == 1){
      wki <- wkk
    } else {
      wki <- which(groups == i)
    }
    
    io <- which(wki %in% wo)
    yq[,wki] <- .gjamCompW2Y(yq[,wki,drop=F],notOther=io)$ww
  }
  list(wq, yq) 
}
  
.gjamWcatLoop <- function(y, ws, mus, sgs, notOther, plo, phi, groups, 
                          REDUCT = F){
  
  # if REDUCT, sgs is length-S sigvec
  # if !REDUCT, sgs is css[notOther,notOther]
  
  ntt <- max( groups )
  n <- nrow(y)
  
  for(i in 1:ntt){  
    
    wki <- which(groups == i)
    nki <- length(wki)
    wko <- wki[wki %in% notOther]
    
    w0 <- apply( ws[,wko]*(1 - y[,wko]),1, max) # max(w, 0) for y = 0
    w1 <- apply( ws[,wko]*y[,wko],1, max)       # w for y = 1
    w0[w0 < 0] <- 0                             # when y is reference
    
    si <- sample(wko)
    
    for(s in si){
      
      y1         <- which(y[,s] == 1)
      plo[-y1,s] <- -500
      phi[y1,s]  <- 500
      plo[y1,s]  <- w0[y1]
      phi[-y1,s] <- w1[-y1]
      
      if(REDUCT){
        
        ws[,s] <- .tnorm(n,plo[,s],phi[,s],mus[,s],sqrt(sgs[s]))
        
      } else {
        sm  <- which(notOther == s)
        tmp <- .conditionalMVN(ws[,notOther], mus[,notOther], 
                                   sgs, sm)
        mue <- tmp$mu
        vr  <- max(tmp$vr,1e-8)
        ws[,s] <- .tnorm(n,plo[,s],phi[,s],mue,sqrt(vr))
      }
      
      w1[y1]  <- ws[y1,s]    #new w for y = 1
      w0[-y1] <- apply( ws[-y1,wki]*(1 - y[-y1,wki]),1, max)
    }
  }
  list(w = ws, plo = plo, phi = phi)
}

.gjamWcatLoop2 <- function(yy, ws, mus, sgs, notOther, plo, phi, groups, 
                           REDUCT = F){
  
  # if REDUCT, sgs is length-S sigvec
  # if !REDUCT, sgs is css[notOther,notOther]
  
  ntt <- max( groups )
  n <- nrow(yy)
  
  for(i in 1:ntt){  
    
    wki <- which(groups == i)
    nki <- length(wki)
    wko <- wki[wki %in% notOther]
    w1  <- apply( ws[,wko]*yy[,wko],1, max)        # w for y = 1
    so  <- match(wko,notOther)
    
    for(s in wko){   
      
      y1 <- which(yy[,s] == 1)      # observed value
      sm  <- which(notOther == s)   # index in sgs = sg[notOther,notOther]
      sn  <- so[so != sm]           # index in sgs for so
      qs  <- wko[wko != s]          
      
      if(REDUCT){
        ws[y1,s] <- .tnorm(length(y1),plo[y1,s],phi[y1,s], mus[y1,s],sqrt(sgs[s]))
      } else {
        tmp <- .conditionalMVN(ws[y1,notOther], mus[y1,notOther], sgs, sm)
        mue <- tmp$mu
        vr  <- max(tmp$vr,1e-8)
        ws[y1,s] <- .tnorm(length(y1),plo[y1,s],phi[y1,s],mue,sqrt(vr))
      }
      
      w1[y1] <- ws[y1,s]        # w for y = 1
      phi[y1,wki] <- w1[y1]
      phi[y1,s]   <- 500
      
      if(REDUCT){     # the zeros
        tmp <- .tnorm(length(y1)*length(qs),plo[y1,qs],phi[y1,qs],
                      mus[y1,qs],sqrt(sgs[s]))
      } else {
        tmp <- .tnormMVNmatrix(ws[y1,notOther],mus[y1,notOther],
                                   smat=sgs, plo[y1,notOther], 
                                   hi=phi[y1,notOther],
                                   whichSample=so)[,sn,drop=F]
      }
      ws[y1,qs] <- tmp
      
      ###########
      if(length(sn) > 0)tmp <- apply( tmp, 1, max ) #########
      tmp[tmp < 0] <- 0
      plo[y1,s]  <- tmp
    }
    ##############
    s <- wki[!wki %in% wko]   #  y = 1 is ref class
    y1 <- which(yy[,s] == 1)
    tmp <- .tnormMVNmatrix(ws[y1,notOther],mus[y1,notOther], smat=sgs, plo[y1,notOther], 
                               hi=phi[y1,notOther], whichSample=so)
    ws[y1,wko] <- tmp[,so]
    #############
  }
  list(w = ws, plo = plo, phi = phi)
}

.gjamWLoop <- function( llist ){
  
  ws <- mus <- sgs <- wkk <- lo <- hi <- sampW <- indexW <- groups <-  NULL
  byCol <- T
  byRow <- F
  
  for(k in 1:length(llist))assign( names(llist)[k], llist[[k]] )
  
  n <- nrow(lo)
  tiny <- .00001
  
  if( byCol ){
    
    iss <- sample( wkk[wkk %in% indexW] )
    
    for(s in iss){
      
      rs <- which(sampW[,s] > 0)
      ls <- lo[drop=F,rs,s]
      hs <- hi[drop=F,rs,s]
      
      tmp <- .conditionalMVN( ws[drop=F,rs,], mus[drop=F, rs,], sgs, cdex = s)
      mu  <- tmp$mu
      vr  <- max(tmp$vr,tiny)
      tmp <- .tnorm(length(rs),ls,hs,mu,sqrt(vr))
      
      wl  <- which(tmp == ls)
      if(length(wl) > 0) tmp[wl] <- ls[wl] + tiny*(ls[wl])
      
      wl  <- which(tmp == hs)
      if(length(wl) > 0) tmp[wl] <- hs[wl] - (1 - tiny)*hs[wl]
      
      ws[rs,s] <- tmp
    }
    
    return(ws)
  }
  
  for(i in indexW){
    
    rs  <- which(sampW[i,] > 0)
    rs  <- rs[rs %in% wkk]
    ws[i,rs] <- .tnormMVNmatrix(ws[drop=F,i,], mus[drop=F,i,],
                               smat=sgs, lo[drop=F,i,], hi[drop=F,i,],
                               whichSample=rs)[,rs]
  }
  ws
}

.setContrasts <- function(xx){
  
  # contrasts where each level is compared to the reference level
  # data must have an attribute for 'reference' class assigned as, e.g.,
  # attr(xdata$soil,'reference') <- 'reference'
  # where xx is xdata$soil and 'reference' is the name that appears in xx
  
  levs  <- attr(xx,'levels') 
  nl    <- length(levs)
  ml    <- nl - 1
  ref <- levs[1]
  
  intType <- attr(xx,'intType')
  
  if(is.null(intType))intType <- 'ref'
    
  wr  <- which(levs == ref)
  
  cj <- matrix(-1/nl,ml,ml)
  diag(cj) <- ml/nl
  rownames(cj) <- levs[-wr]
  colnames(cj) <- levs[-wr]
  
  rj <- rep(-1/nl,ml)
  cj <- rbind(rj,cj)
  rownames(cj)[1] <- ref
  
  levs <- as.character(levs)
  
  cj <- cj[drop=F,levs,]
  if(intType == 'ref'){
    cj[cj > 0] <- 1
    cj[cj < 0] <- 0
  }
  list(levs = levs, cont = cj)
}

.gjamXY <- function(formula, xdata, y, typeNames, notStandard, 
                    checkX = T, xscale = NULL, verbose = F){
  
  n        <- nrow(xdata)
  S        <- ncol(y)
  snames   <- colnames(y)
  facNames <- character(0)
  factorList <- contrast <- NULL
  colnames(xdata) <- .cleanNames(colnames(xdata))
  NOX <- T
  xmean <- 1
  
  xdataNames <- original <- colnames(xdata)
  
  
  if( !is.null(notStandard) )notStandard <- .cleanNames(notStandard)
  
  form   <- attr( terms(formula), 'term.labels' )
  xdata0 <- xdata
  
  if( length(form) > 0 ){                # not done if formula = ~ 1
    
    NOX  <- F
    form <- .cleanNames(form)
    form <- paste0(form,collapse=' + ')
    formula <- as.formula( paste('~',form) )
    
    # no transformation
    t1 <- attr( terms(formula), 'term.labels' )
    wi <- grep('I(',t1,fixed=T)
    if(length(wi) > 0)t1 <- t1[-wi]      # linear terms
    
    wi <- grep(':',t1,fixed=T)
    if(length(wi) > 0)t1 <- t1[-wi]
    
    xdata0 <- xdata[,t1, drop=F]
    xnames <- colnames(xdata0)
    
    # check for character strings
    fs <- which( sapply( xdata0, is.character ) )
    if(length(fs) > 0)stop( paste( names(fs), 'is a character, change to factor?',
                                   sep=' ') )
    
    standX   <- !sapply(xdata0,is.factor)
    facNames <- names(standX)[!standX]
    standX   <- names(standX)[standX]
    standX   <- standX[!standX %in% notStandard]
    
    tmp <- .getStandX( formula, xu = xdata0, standRows = standX )
    xdata0 <- tmp$xdataStand
    xmean  <- tmp$xmu
    xsd    <- tmp$xsd
    xscale <- rbind(xmean,xsd)
    
    factorList <- contrast <- vector('list',length = length(facNames))
    names(factorList) <- facNames
    
    if(length(facNames) > 0){
      
      for(j in 1:length(facNames)){
        
        wj <- which(names(xdata0) == facNames[j])
        xf <- as.character(xdata0[[wj]])
        
        cj <- attr(xdata0[[wj]],'contrasts')
        contrast[[j]] <- cj
        tt <- .setContrasts(xdata0[[wj]])$cont
        factorList[[j]] <- paste(facNames[j],colnames(tt),sep='')
        
        if(!is.null(cj))next                       # contrasts previously set
        
        contrast[[j]] <- tt
        attr(xdata0[[wj]],'contrasts') <- tt
      }
      names(contrast) <- facNames
    }  
  }
  
  tmp <- model.frame(formula, data = as.data.frame(xdata0), na.action=NULL)
  x   <- model.matrix(formula, data=tmp)
  colnames(x)[1] <- 'intercept'
  
  xnames <- colnames(x)
  snames <- colnames(y)
  Q      <- ncol(x)
  predXcols <- 2:Q
  isFactor <- character(0)
  if(Q < 2) checkX <- FALSE
  
  notStandard <- notStandard[ notStandard %in% colnames(x) ]
  
  facBySpec <- missFacSpec <- NULL
  
  VIF <- isNonLinX <- designTable <- NULL
  isInt <- intMat <- numeric(0)
  
  if( !NOX ){
    
    if( length(facNames) > 0 ){
      
      iy <- y*0
      iy[y > 0] <- 1
      facBySpec <- numeric(0)
      missFacSpec <- character(0)
      
      for(j in 1:length(facNames)){
        
        ij <- which( colnames(x) %in% factorList[[j]] )
        ij <- xnames[ij]
        isFactor <- c(isFactor,ij)
        
        if(verbose){
          print(paste('observations in factor',facNames[j]))
          print(colSums(x, na.rm=T)[ij])
        }
        
        fs <- matrix(NA,S,length(factorList[[j]]))
        colnames(fs) <- factorList[[j]]
        rownames(fs) <- snames
        
        for(k in 1:length(ij)){
          xi   <- ij[k]
          fs[,k] <- colSums( matrix(x[,xi],n,S)*iy, na.rm=T )
        }
        ms <- 'none missing'
        missFS <- which(fs == 0,arr.ind=T)
        if(length(missFS) > 0){
          ms <- paste(rownames(missFS),ij[missFS[,2]],sep='_')
        }
        
        facBySpec <- append(facBySpec,list(fs))
        missFacSpec <- append(missFacSpec,list(ms))
        
      }
      names(facBySpec) <- names(missFacSpec) <- facNames
    }
    
    # check design
    
    if( checkX ){
      
      checkInt <- range(x[,1])
      if(checkInt[1] != 1 | checkInt[2] != 1)
        stop( paste('x[,1] must be intercept (ones)') )
      
      tmp <- .checkDesign(x)
      if(tmp$rank < tmp$p)stop( 'x not full rank' )
      VIF         <- tmp$VIF
      designTable <- tmp$designTable$table
      
      wx <- grep('^2',colnames(x),fixed=T)
      if(length(wx) > 0){
        mm <- unique(unlist(strsplit(colnames(x)[wx],'^2)',fixed=T)))
        mm <- .replaceString(mm,'I(','')
        mm <- match(mm,colnames(x))
        mat <- cbind(wx,mm,mm)
        colnames(mat) <- c('int','main1','main2')
        intMat <- mat
        isInt <- wx
        isNonLinX <- sort(unique( c(isNonLinX,mm,isInt)))
      }
      
      wx <- grep(':',colnames(x))
      if(length(wx) > 0){
        mm  <- matrix(unlist(strsplit(colnames(x)[wx],':')),ncol=2,byrow=T)
        mat <- matrix( match(mm,colnames(x)), ncol=2)
        mat <- cbind(wx,mat)
        colnames(mat) <- c('int','main1','main2')
        wx <- c( which(colnames(x) %in% mm),wx )
        isInt <- sort(c(isInt,wx))
        intMat <- rbind(intMat,mat)
      }
      if(!is.null(isInt))isNonLinX <- sort(unique( c(isNonLinX,isInt)))
    }
  }
  
  standMatSd <- matrix(1,Q,1)
  rownames(standMatSd) <- xnames
  standMatMu <- standMatSd - 1
  
  xss <- colnames(xscale)
  
  if(length(xss) > 0){
    standMatMu[xss,] <-  xscale['xmean',xss]
    standMatSd[xss,] <-  xscale['xsd',xss]
  }
  
  # standardize in interactions
  
  if( length(intMat) > 0 ){
    
    for(j in 1:nrow(intMat)){
      im <- intMat[j,]
      s1 <- s2 <- 1
      if( xnames[im[2]] %in% colnames(xscale) )s1 <- xscale['xsd',xnames[im[2]]]
      if( xnames[im[3]] %in% colnames(xscale) )s2 <- xscale['xsd',xnames[im[3]]]
      standMatSd[im[1],] <- s1*s2
    }
  }
  
  standRows <- which(standMatSd[,1] != 1 | standMatMu[,1] != 0)
  standRows <- standRows[!names(standRows) %in% notStandard]
  
  colnames(y) <- .cleanNames(colnames(y))  
  
  # check composition
  
  tiny <- 1 + 1e-10
  
  if('FC' %in% typeNames){
    
    groups <- attr(typeNames,'FCgroups')
    
    if(is.null(groups)){
      groups <- rep(0,S)
      groups[typeNames == 'FC'] <- 1
      attr(typeNames,'FCgroups') <- groups
    }
    
    ngg    <- max(groups)
    for(kk in 1:ngg){
      wf <- which(groups == kk)
      if(length(wf) == 0)stop( 'FC data must have > 1 column' )
      ww <- which(y[,wf] < 0)
      if(length(ww) > 0)stop( 'FC values cannot be < 0' )
      wr <- rowSums(y[,wf],na.rm=T)
      vv <- unique(wr)
      ww <- which(vv != 0 & vv > 1.01)
      if(length(ww) > 0){
        wx <- which(wr %in% vv)
        ii <- paste0(wx, collapse=', ')
        stop( paste('FC data must sum to zero (all absent) or one, check obs:',ii))
      }
    }
  }
  
  if('CC' %in% typeNames){
    wf <- which(typeNames == 'CC')
    if(length(wf) < 2)stop( 'CC data must have > 1 column' )
  }
  
  if(is.null(snames))snames <- paste('S',1:S,sep='-')
  if(is.null(xnames))xnames <- paste('x',1:Q,sep='-')
  
  snames <- sub('_','-',snames)
  xnames <- sub('_','-',xnames)
  
  colnames(y) <- snames
  colnames(x) <- xnames
  
  if(length(isNonLinX) == 0)isNonLinX <- NULL
  if(length(notStandard) == 0)notStandard <- NULL
  
  if( !is.null(notStandard) ){
    ns <- notStandard[ notStandard %in% colnames(x) ]
    for(k in 1:length(ns)){
      wk <- grep(ns[k],colnames(x))
      ns <- c(ns,colnames(x)[wk])
    }
    notStandard <- sort( unique(ns) )
  }
  
  factorAll <- list(nfact = length(factorList), factorList = factorList, 
                     isFactor = isFactor, contrast = contrast,
                     facBySpec = facBySpec, missFacSpec = missFacSpec,
                     facNames  = facNames)
  interaction <- list(isInt = isInt, intMat = intMat, isNonLinX = isNonLinX)
  
  list(x = x, y = y, snames = snames, xnames = xnames, predXcols = predXcols,
       interaction = interaction,factorAll = factorAll,
       xdata = xdata, designTable = designTable, xmean = xmean, xscale = xscale,
       standMatMu = standMatMu, standMatSd = standMatSd, standRows = standRows,
       notStandard = notStandard, xdataNames = xdataNames, formula = formula)
}

.gjamCompW2Y <- function(ww,notOther=c(1:(ncol(ww)-1))){
  
  pg <- .995
  
  n  <- nrow(ww)
  ww[ ww < 0 ] <- 0
  W  <- rowSums(ww[,notOther,drop=F])
  wh <- which(W > pg)
  other <- c(1:ncol(ww))[-notOther]
  
  if(length(wh) > 0){
    contract <- (1 - (1 - pg)^(W[wh]/pg))/W[wh]
    ww[wh,]  <- ww[wh,]*contract        
  }
  
  ww[,other] <- 1 - rowSums(ww[,notOther,drop=F])
  
  list(pg = pg, ww = ww )
}

.imputX_MVN <- function(xx,yy,beta,xmiss,sinv,xprior=0,xbound=NULL,priorWT=1){
  
  # priorWT is inverse of variance
  
  wcol <- unique(xmiss[,2])
  S    <- nrow(sinv)
  Q    <- nrow(beta)
  
  if(is.null(xbound))xbound <- apply(xx,2,range,na.rm=T)
  
  for(j in wcol){
    
    wx <- which(xmiss[,2] == j)
    
    wj <- xmiss[drop=F,wx,]     # rows, col, missing col j
    wr <- wj[,1]                            # rows missing col j
    xp <- xprior[wx]                    # prior mean
    
    bj <- matrix(beta[j,],1)                # row for missing x
    bn <- matrix(beta[-j,],Q - 1)           # other rows
    
    xn <- xx[drop=F,wr,-j]                  # other cols
    z  <- yy[drop=F,wr,] - xn%*%bn          # y - not missing xb
    datwt <- bj%*%sinv%*%t(bj)              # conditional var
    V     <- 1/( datwt + priorWT*datwt )     
    v     <- z %*%sinv%*%t(bj) + xp*priorWT # conditional 
    xx[wj] <- .tnorm(length(wr),xbound[1,j],xbound[2,j],v%*%V,sqrt(V))
  }
  xx
}

.interp <- function(y,INCREASING=F,minVal=-Inf,maxVal=Inf,defaultValue=NULL,
                   tinySlope=NULL){  #interpolate vector x

  if(is.null(defaultValue))defaultValue <- NA

  tiny <- .00001
  if(!is.null(tinySlope))tiny <- tinySlope

  y[y < minVal] <- minVal
  y[y > maxVal] <- maxVal

  n  <- length(y)
  wi <- which(is.finite(y))

  if(length(wi) == 0)return(rep(defaultValue,n))
  if(length(wi) == 1)ss <- tiny

  xx  <- c(1:n)
  z  <- y

  if(wi[1] != 1) wi <- c(1,wi)
  if(max(wi) < n)wi <- c(wi,n)

  ss <- diff(z[wi])/diff(xx[wi])

  ss[is.na(ss)] <- 0

  if(length(ss) > 1){
    if(length(ss) > 2)ss[1] <- ss[2]
    ss[length(ss)] <- ss[length(ss)-1]
  }
  if(INCREASING)ss[ss < tiny] <- tiny

  if(is.na(y[1]))  z[1] <- z[wi[2]] - xx[wi[2]]*ss[1]
  if(z[1] < minVal)z[1] <- minVal
  if(z[1] > maxVal)z[1] <- maxVal

  for(k in 2:length(wi)){

     ki <- c(wi[k-1]:wi[k])
     yk <- z[wi[k-1]] + (xx[ki] - xx[wi[k-1]])*ss[k-1]
     yk[yk < minVal] <- minVal
     yk[yk > maxVal] <- maxVal
     z[ki] <- yk
  }
  z
}

.interpRows <- function(x,startIndex=rep(1,nrow(x)),endIndex=rep(ncol(x),nrow(x)),
                       INCREASING=F,minVal=-Inf,maxVal=Inf,
                       defaultValue=NULL,tinySlope=.001){  
  #interpolate rows of x subject to increasing

  nn  <- nrow(x)
  p  <- ncol(x)
  xx <- c(1:p)

  if(length(minVal) == 1)minVal <- rep(minVal,nn)
  if(length(maxVal) == 1)maxVal <- rep(maxVal,nn)

  ni   <- rep(NA,nn)
  flag <- numeric(0)

  z <- x

  for(i in 1:nn){
    if(startIndex[i] == endIndex[i]){
      z[i,-startIndex[i]] <- NA
      next
    }
    z[i,startIndex[i]:endIndex[i]] <- .interp(x[i,startIndex[i]:endIndex[i]],
                                             INCREASING,minVal[i],maxVal[i],
                                             defaultValue,tinySlope)
  }
  
  z
}

.invertSigma <- function(sigma,sigmaerror=NULL,otherpar=NULL, REDUCT){
  
  if(REDUCT){
    sinv <- invWbyRcpp(sigmaerror, otherpar$Z[otherpar$K,])
  } else {
    testv <- try( chol(sigma) ,T)
    if( inherits(testv,'try-error') ){
      tiny  <- .1*diag(sigma)
      sigma  <- sigma + diag(diag(sigma + tiny))
      testv <- try(chol(sigma),T)
    }
    sinv    <- chol2inv(testv)
  }
  sinv
}

.invMatZero <- function(sgibbs,nsim=2000,snames,knames,index=NULL,
                        COMPRESS = F, REDUCT=F,
                        sigErrGibbs = NULL, kgibbs = NULL,
                        otherpar = NULL, alpha = .95){   
  # return conditional independence
  # if COMPRESS, sgibbs is as.vector(lower.tri(Sigma,diag=T) )
  # alpha: prob that covariance/inverse is not zero 
  
  S <- length(snames)
  
  if(is.null(index))index <- c(1:nrow(sgibbs))
  simIndex   <- sample(index,nsim,replace=T)
  
  if(!REDUCT){
    
    if(COMPRESS){
      tmp <- .expandSigmaChains(snames, sgibbs, otherpar, 
                                simIndex, sigErrGibbs, kgibbs, 
                                REDUCT=REDUCT, CHAINSONLY=T)$chainList$schain
      sgibbs <- tmp
    }
    S1 <- sqrt(ncol(sgibbs))
  } else {
    N  <- otherpar$N
    r  <- otherpar$r
    S1 <- S
    SS <- matrix(0,S1,S1)
  }
  
  SK     <- length(knames)
  sindex <- match(knames,snames)
  mm     <- matrix(0,SK,SK)
  rownames(mm) <- colnames(mm) <- knames
  hiSS <- loSS <- hiSI <- loSI <- mm
  
  for(j in simIndex){
    if(!REDUCT){
      ss <- matrix(sgibbs[j,],S1,S1) 
      si <- chol2inv(chol( ss ) ) 
      
    } else {
      Z  <- matrix(sgibbs[j,],N,r)
      ss <- .expandSigma(sigErrGibbs[j], S1, Z = Z, kgibbs[j,], REDUCT = T)
      si <- invWbyRcpp(sigErrGibbs[j], Z[kgibbs[j,],])
    }
    
    ss <- ss[sindex,sindex]
    si <- si[sindex,sindex]
    
    hiSS[ss > 0] <- hiSS[ss > 0] + 1/nsim
    loSS[ss < 0] <- loSS[ss < 0] + 1/nsim
    hiSI[si > 0] <- hiSI[si > 0] + 1/nsim
    loSI[si < 0] <- loSI[si < 0] + 1/nsim
  }
  
  loMar <- which(loSS > alpha)
  hiMar <- which(hiSS > alpha)
  inMar <- which(loSS < alpha & hiSS < alpha)   # not different from zero
  
  loCon <- which(loSI > alpha)
  hiCon <- which(hiSI > alpha)
  inCon <- which(loSI < alpha & hiSI < alpha)
  
  inMarMat <- which(loSS < alpha & hiSS < alpha,arr.ind=T)
  inConMat <- which(loSI < alpha & hiSI < alpha,arr.ind=T)
  
  list( inMarMat = inMarMat, inConMat = inConMat )
}

.mapSetup <- function(xlim,ylim,scale=NULL,widex=10.5,widey=6.5){  
  
  #scale is x per inch
  #new means not a new plot
  
  if(is.null(scale))scale <- 1

  px   <- diff(xlim)/scale
  py   <- diff(ylim)/scale
  
  if(px > widex){
    dx <- widex/px
    px <- widex
    py <- py*dx
  }
  if(py > widey){
    dx <- widey/py
    py <- widey
    px <- px*dx
  }
    
  par(pin=c(px,py))
  invisible( c(px,py) )
}

.sameByColumn <- function(mat,fraction=F){
  
  nc <- ncol(mat)
  
  sameMat <- matrix(0,nc,nc)
  
  for(j in 2:nc){
    for(k in 1:(j - 1)){
       wj <- which(mat[,j] == mat[,k])
       sameMat[j,k] <- length(wj)
    }
  }
  fraction <- sameMat/nrow(mat)
  fraction[upper.tri(fraction, diag=T)] <- NA
  fraction
}

.modalValuesInArray <- function(mat,idim = 1){
  
  # modal values for each row (idim = 1) or column (idim = 2)
  
  as.numeric( apply(mat,idim,
                    function(x) names(which.max(table(x)))) )
}

.multivarChainNames <- function(rowNames,colNames, keep = NULL){
  
  tmat <- t(outer(colNames,rowNames,paste,sep='_'))
  if(!is.null(keep))tmat <- tmat[ keep ]
  as.vector( tmat )
}


.multivarChainNames2matrix <- function( chainNames, dimnames ){
  
  ss   <- columnSplit( chainNames, '_' )
  tmat <- matrix(0, length(dimnames[[1]]), 
                 length(dimnames[[2]]), dimnames = dimnames )
  
  wr <- match( ss[,2], dimnames[[1]] )
  wc <- match( ss[,1], dimnames[[2]] )
  wB <- cbind( wr, wc )
  
  tmat[ wB ] <- 1

  list( beta = tmat, wB = wB)
}

.rMVN <- function (nn, mu, sigma = NULL, sinv = NULL){
  
  # nn - no. samples from one mu vector or nrow(mu) for matrix
  
  if(!is.null(sigma)){
    m <- ncol(sigma)
  }else if(!is.null(sinv)){
    m <- ncol(sinv)
  }else{
    stop( '.rMNV requires either sigma or sinv' )
  }
  
  if(length(mu) > 1){
    if( !is.matrix(mu) ) mu <- matrix( mu, nn, length(mu) )  # mu is a vector of length m
    if( ncol(mu) == 1 & nn == 1 )  mu <- t(mu)
    if( length(mu) == m & nn > 1) mu <- matrix( mu, nn, length(mu), byrow=T )
  }
  
  if(is.null(sinv)){          # from sigma
    
    vv <- try(svd(sigma),T)
    
    if( inherits(vv,'try-error') ){
      ev <- eigen(sigma, symmetric = TRUE)
      rr <- t(ev$vectors %*% (t(ev$vectors) * sqrt(ev$values)))
    } else {
      rr <- vv$v %*% (t(vv$u) * sqrt(vv$d)) 
    }
  
  }else{     # from sinv
    
    L  <- chol(sinv)  
    rr <- backsolve(t(L), diag(m), upper.tri = F) 
  }
  ps <- matrix(rnorm(nn * m), nn) %*% rr
  ps + mu 
}

.omitChainCol <- function(cmat,omitCols){
  
  #omitCols - characterVector
  
  keep <- c(1:ncol(cmat))
  ocol <- numeric(0)
  for(j in 1:length(omitCols)){
    ocol <- c(ocol,grep(omitCols[j],colnames(cmat)))
  }
  if(length(ocol) > 0)keep <- keep[-ocol]
  list(keep = keep, omit = ocol)
}

.outFile <- function(outFolder=character(0),file){
  paste(outFolder,file,sep='/')
}

.plotLabel <- function(label,location='topleft',cex=1.3,font=1,
                       above=F,below=F,bg=NULL){
  
  if(above){
    adj <- 0
    if(location == 'topright')adj=1
    title(label,adj=adj, font.main = font, font.lab =font)
    return()
  }
  if(below){
    adj <- 0
    if(location == 'bottomright')adj=1
    mtext(label,side=1,adj=adj, outer=F,font.main = font, font.lab =font,cex=cex)
    return()
  }
    
  if(is.null(bg)){
    tmp <- legend(location,legend=' ',bty='n')
  } else {
    tmp <- legend(location,legend=label,bg=bg,border=bg,text.col=bg,bty='o')
  }
  
  xt <- tmp$rect$left # + tmp$rect$w
  yt <- tmp$text$y
  
  pos <- 4
  tmp <- grep('right',location)
  if(length(tmp) > 0)pos <- 2
  
  XX <- par()$xlog
  YY <- par()$ylog
  
  if(XX)xt <- 10^xt
  if(YY)yt <- 10^yt
  
  text(xt,yt,label,cex=cex,font=font,pos=pos)
}

.bins4data <- function(obs, nPerBin=NULL, breaks=NULL, nbin=NULL, LOG=F, POS=T){
  
  if(!is.null(nPerBin)){
    mb <- 20
    if(length(obs)/nPerBin > mb)nperBin <- length(obs)/mb
  }
      
  if( is.null(breaks) ){
    
    if( is.null(nbin) )nbin <- 20
    
    br   <- range(obs[is.finite(obs)],na.rm=T)
    bins <- seq(br[1],br[2],length=nbin)
    if(LOG){
      yy <- obs[obs > 0]
      oo <- min( yy,na.rm=T )
      
      ybin <- seq(log10(oo),log10(max(yy, na.rm=T)),length=20)
      bins <- 10^c(log10(.1*oo),ybin)
      bins <- unique(bins)
      nbin <- length(bins)
      
      nPerBin <- NULL
    }
    
    if( !is.null(nPerBin) ){
      nbb <- nPerBin/length(obs)
      if(nbb < .05)nbb <- .05
      nbb <- seq(0,1,by=nbb)
      if(max(nbb) < 1)nbb <- c(nbb,1)
      oo   <- obs
      if(POS)oo <- obs[obs > 0]
      bins <- quantile(oo,nbb,na.rm=T)
      bins <- c(min(oo,na.rm=T),bins)
      bins <- sort(unique(bins))
      
      db <- diff(bins)
      qo <- quantile(obs,c(.1,.9),na.rm=T)
      wb <- which( db/diff(range(qo)) < .02)
      wb <- wb[wb != 1]
      if(length(wb) > 0)bins <- bins[-wb]
      
      nbin <- length(bins)
    }
  } else {
    bins <- breaks
    nbin <- length(bins)
  }
  
  list(breaks = breaks, bins = bins, nbin = nbin)
}

.predictY2X_linear <- function(xpred,yy,bb,ss,sinv=NULL, 
                               priorIV = diag(1e-10,ncol(xpred)), 
                               priorX = matrix(0,ncol(xpred)), 
                               predCols = c(2:ncol(xpred)),REDUCT, lox, hix, propx){
  
  #inverse prediction for multivariate linear in x
  
  prX <- priorX[predCols]
  if(!is.matrix(prX))prX <- matrix(prX)
  
  nn <- nrow(yy)
  notPred <- c(1:ncol(xpred))[-predCols]
  
  bp <- matrix(bb[drop=F,predCols,],length(predCols))
  
  if(length(notPred) > 0){
    bn <- matrix(bb[notPred,],length(notPred))
    yy <- yy - xpred[,notPred]%*%bn
  }
  pp <- length(predCols)
  
  if(is.null(sinv))sinv <- chol2inv(chol(ss))
  
  bs <- bp%*%sinv
  
  V <- chol2inv(chol( bs%*%t(bp) + priorIV[predCols,predCols] ) )
  v <- yy%*%t(bs) + matrix( priorIV[predCols,predCols] %*% prX,nn,pp,byrow=T)
  mu <- v%*%V
  
  qq <- ncol(mu)
  
  if(qq > 1){
    xpred[,predCols] <- .tnormMVNmatrix(avec=xpred[,predCols, drop=F],muvec=mu,smat=V,
                               lo=matrix(lox[predCols],nn,qq,byrow=T),
                               hi=matrix(hix[predCols],nn,qq,byrow=T))
  } else {
    xpred[,predCols] <- .tnorm(nn,lox[predCols],hix[predCols], mu,sqrt(V))
  }
  xpred
}

.predictY2X_nonLinear <- function(xx,yy,bb,ss,
                                  priorIV = diag(1e-10,ncol(xx)), 
                                  priorX=matrix(0,ncol(xx)),
                                  factorObject, interObject, lox, hix, propx){
  
  #inverse prediction for multivariate nonlinear in x and factors, metropolis
  
   predCols <- interObject$isNonLinX
   isInt    <- interObject$isInt
   intMat   <- interObject$intMat
   isFactor <- factorObject$isFactor
   factorList <- factorObject$factorList
   contrast  <- factorObject$contrast
  
  iFcol  <- NULL
  priorX <- priorX[predCols]
  if(!is.matrix(priorX))priorX <- matrix(priorX)
  
  nn <- nrow(yy)
  intercept <- xx[,1]
  
  xnew <- xx
  
  
  xv <- as.vector(xx[,predCols])
  nv <- length(xv)
  lo <- rep(lox[predCols],each=nn)
  hi <- rep(hix[predCols],each=nn)
  sx <- rep(propx[predCols],each=nn)/10
  
  xnew[,predCols] <- .tnorm(nv,lo,hi,xv,sx)
  
  if(length(isFactor) > 0){          # all factors, main effects
    np <- length(factorList)
    for(k in 1:np){
      nf <- length(factorList[[k]]) + 1
      tm <- contrast[[k]][sample(nf,nn,replace=T),]
      xnew[,factorList[[k]]] <- tm
    }
    iFcol <- match(isFactor,colnames(xx))
  }
  
  if(length(intMat) > 0){     # some of the nlin terms interactions?
    xnew[,intMat[,1]] <- xnew[,intMat[,2]]*xnew[,intMat[,3]]
  }
  
  mux <- matrix( priorX, nn, length(priorX), byrow=T )
  
  pnow <- .dMVN(yy,xx%*%bb,smat=ss,log=T) + 
    .dMVN(xx[,predCols,drop=F], mux, priorIV[drop=F, predCols,predCols] )
  pnew <- .dMVN(yy,xnew%*%bb,smat=ss,log=T)+ 
    .dMVN(xnew[,predCols,drop=F], mux, priorIV[drop=F, predCols,predCols] )
  
  a  <- exp(pnew - pnow)
  z  <- runif(nn,0,1)
  wa <- which(z < a)
  xx[wa,] <- xnew[wa,]
  
  list(x = xx, accept = length(wa))
}

.predVsObs <- function(true,p,xlim=range(true),ylim=range(p,na.rm=T),xlab=' ',
                       ylab=' ', colors=rep(1,length(true)),lwd=2,add=F){ 
	
  #true  - length n vector of obs or true values
  #p - ng by n matrix of estimates
  
  if(!is.matrix(p))p <- matrix(p,ncol=1)
  
  if(length(colors) == 1)colors <- rep(colors, length(true))
  
  nn <- length(true)
  y  <- apply(p, 2, quantile, c(.5,.025,.975))
  ys <- apply(p, 2, quantile, pnorm( c(-1, 1) ) )
  
  if(!add)plot(true,y[1,],xlim=xlim,ylim=ylim,xlab=xlab,
               ylab=ylab,col=colors,pch=3,lwd=lwd)
  points(true,y[1,],col=colors,pch=3,lwd=lwd)

  for(j in 1:nn)lines( c(true[j],true[j]), y[2:3,j], col=colors[j],lwd=lwd/2)
  for(j in 1:nn)lines( c(true[j],true[j]), ys[1:2,j], col=colors[j],lwd=2*lwd)
  
  abline(0,1,lty=2)
  
  invisible(y)
}

.processPars <- function(xgb,xtrue=numeric(0),CPLOT=F,DPLOT=F,
                         sigOnly = F,burnin=1,xlimits = NULL){  

  #xg      - matrix of gibbs chains
  #xtrue   - true values (simulated data)
  #CPLOT   - if T, plot chains
  #DPLOT   - if T, plot density
  #burnin  - analyze chains > burnin
  #xlimits - xlimits for plot
  #sigOnly - plot only parameters that 95% CI does not include 0
  
  if(!is.matrix(xgb))xgb <- matrix(xgb,ncol=1)
  if(is.null(colnames(xgb)))colnames(xgb) <- paste('V',c(1:ncol(xgb)),sep='-')
  
  NOPARS <- F
  
  if(sigOnly){
    wi   <- grep('intercept',colnames(xgb))      #extract covariates for plotting
    btmp <- xgb
    if(length(wi) > 0){
    	btmp <- xgb[,-wi]
      if(length(xtrue) > 0)xtrue <- xtrue[-wi]
    }

    wq   <- apply(btmp,2,quantile,c(.025,.975),na.rm=T)  #extract parameters != 0
    wq   <- which(wq[1,] < 0 & wq[2,] > 0)
    
    if(length(wq) == ncol(btmp))NOPARS <- T
    if(NOPARS) warning('no significant pars to plot')
    if(length(wq) > 0 & !NOPARS){
      xgb  <- btmp[,-wq]
      if(length(xtrue) > 0)xtrue <- xtrue[-wq]
    }
   }

  if(!is.matrix(xgb))xgb <- as.matrix(xgb)
  if(burnin > 1){
  	     if(burnin > (nrow(xgb) + 100))stop("burnin too large")
  	     xgb <- xgb[-c(1:burnin),]
  }
  if(!is.matrix(xgb))xgb <- as.matrix(xgb)
  nc <- ncol(xgb)
  nf <- round(sqrt(nc),0)

  out <- t(rbind(apply(xgb,2,mean,na.rm=T),apply(xgb,2,sd,na.rm=T),
                 apply(xgb,2,quantile,c(.025,.975),na.rm=T)))
  if(!is.null(colnames(xgb)))rownames(out) <- colnames(xgb)
  colnames(out) <- c('estimate','se','0.025','0.975')
  if(length(xtrue) > 0){
    out <- cbind(out,xtrue)
    colnames(out) <- c('estimate','se','0.025','0.975','true value')
  }

  if(CPLOT | DPLOT)par(mfrow=c((nf+1),nf),mar=c(4,2,2,2))
  if(CPLOT & DPLOT)par(mfrow=c((nf+1),nc),mar=c(4,2,2,2))

  if(CPLOT & !NOPARS){
      for(j in 1:nc){
       plot(xgb[,j],type='l')
       abline(h=out[j,],lty=2)
       if(length(xtrue) > 0)abline(h=xtrue[j],col='red')
       abline(h = 0, col='grey',lwd=2)
       title(colnames(xgb)[j])
     }
  }
  xlims <- xlimits
  if(DPLOT & !NOPARS){
      for(j in 1:nc){
        xj <- density(xgb[,j])
        if(is.null(xlimits))xlims <- range(xj$x)
        plot(xj$x,xj$y,type='l',xlim=xlims)
        abline(v=out[j,],lty=2)
        if(length(xtrue) > 0)abline(v=xtrue[j],col='red')
        title(colnames(xgb)[j])
     }
  }
  list(summary = signif(out,4))
}

.replaceString <- function(xx,now='_',new=' '){  #replace now string in vector with new
  
  ww <- grep(now,xx,fixed=T)
  if(length(ww) == 0)return(xx)
  
  for(k in ww){
    s  <- unlist( strsplit(xx[k],now,fixed=T) )
    ss <- s[1]
    if(length(s) == 1)ss <- paste( ss,new,sep='')
    if(length(s) > 1)for(kk in 2:length(s)) ss <- paste( ss,s[kk],sep=new)
    xx[k] <- ss
  }
  xx
}

.cleanNames <- function(xx){
  
  xx <- .replaceString(xx,'-','')
  xx <- .replaceString(xx,'_','')
  xx <- .replaceString(xx,' ','')
  xx <- .replaceString(xx,"'",'')
  
  xx
}

.buildYdata <- function(ydata, ytypes){
  
  # when y has factors, data.frame to matrix
  
  S <- ncol(ydata)
  
  wd <- which(duplicated(colnames(ydata)))
  if(length(wd) > 0){
    warning('duplicated colummn names in ydata')
    for(k in 1:length(wd)){
      dname <- colnames(ydata)[wd[k]]
      wk    <- which(colnames(ydata) == dname)
      colnames(ydata)[wk] <- paste(dname,1:length(wk),sep='')
    }
  }
  
  original <- colnames(ydata)
  colnames(ydata) <- .cleanNames(colnames(ydata))
 
  new <- colnames(ydata)
  ydataNames <- rbind(original,new)
  
  CCgroups  <- attr(ytypes,'CCgroups')
  FCgroups  <- attr(ytypes,'FCgroups')
  CATgroups <- attr(ytypes,'CATgroups')
  
  ngroup  <- 0
  ccg     <- CCgroups
  fcg     <- FCgroups
  y       <- numeric(0)

  snames <- colnames(ydata)
  nc     <- ncol(ydata)
  wfact  <- .whichFactor(ydata)
  nfact  <- length(wfact)
  wnot   <- c(1:nc)
  if(nfact > 0)wnot <- wnot[-wfact]
  
  ntypes <- character(0)
  
  if(length(wnot) > 0){
    
    if(is.null(ccg)) ccg <- rep(0,length(wnot)) # if not assigned, assume same 
    if(is.null(fcg)) fcg <- rep(0,length(wnot))
    
    snames <- snames[wnot]
    ntypes <- ytypes[wnot]
    y      <- ydata[,wnot,drop=F]
    
    wcomp <- grep('CC',ytypes[wnot])
    ncomp <- length(wcomp)
    if(ncomp > 0){
      if( max(ccg[wnot[wcomp]]) == 0 )ccg[wnot[wcomp]] <- 1  #assume same group
      goo <- grep('other',snames[wcomp])
      if( length(goo) == 0 )snames[wcomp[ncomp]] <- 
        paste(snames[wcomp[ncomp]],'other',sep='')
    }
    
    wcomp <- grep('FC',ytypes[wnot])
    ncomp <- length(wcomp)
    if(ncomp > 0){
      if( max(fcg[wnot[wcomp]]) == 0)fcg[wnot[wcomp]] <- 1  #assume same group
      goo <- grep('other',snames[wcomp])
      if(length(goo) == 0)snames[wcomp[ncomp]] <- 
        paste(snames[wcomp[ncomp]],'other',sep='')
    }
  }
  
  if(nfact > 0){   # categorical
    
    ngroup <- 0
    ycat   <- cag <- numeric(0)
    if(length(ccg) > 0)cag    <- ccg*0
    
    for(j in 1:nfact){
      
      ngroup <- ngroup + 1
      
      conj   <- contrasts(ydata[,wfact[j]],contrasts=F)
      cj     <- colnames(conj)
      yj     <- conj[ydata[,wfact[j]],]
      colnames(yj) <- paste(colnames(ydata)[wfact[j]],cj,sep='')
      
      w11    <- which(colSums(yj) > 0)  #drop empty levels
      yj     <- yj[,w11]
      cj     <- cj[w11]
      
      goo <- grep('other',colnames(yj))
      if(length(goo) == 0){
        colnames(yj)[ncol(yj)] <- paste(colnames(ydata)[wfact[j]],'other',sep='')
        cj[ncol(yj)] <- colnames(yj)[ncol(yj)]
      }
      
      ycat   <- cbind(ycat, yj)
      cag    <- c(cag,rep(ngroup,length(cj)))
      fcg    <- c(fcg,rep(0,length(cj)))
      ccg    <- c(ccg,rep(0,length(cj)))
      ntypes <- c(ntypes,rep('CAT',length(cj)))
    }
    
    rownames(ycat) <- NULL
    n1 <- ncol(y) + 1
    n2 <- ncol(ycat)
    y <- cbind(y,ycat)
    attr(ntypes,'CATgroups')  <- cag
  }
  
  if(max(ccg) > 0)attr(ntypes,'CCgroups') <- ccg
  if(max(fcg) > 0)attr(ntypes,'FCgroups') <- fcg

  list(y = as.matrix(y), CCgroups = ccg, FCgroups = fcg, 
       CATgroups = attr(ntypes,'CATgroups'), typeNames = ntypes,
       ydataNames = ydataNames)
}

.setUpSim <- function(n, S, Q, x, typeNames){
  
  if(length(typeNames) == 1)typeNames <- rep(typeNames,S)
  
  notOther <- c(1:S)
  snames   <- character(0)
  tnames   <- character(0)
  sN       <- S
  catCols  <- NULL
  
  ngroup <- fgroup <- cgroup <- 1
  GROUPS <- F
  CCgroups <- FCgroups <- CATgroups <- numeric(0)
  s      <- 0
  
  wcc <- which(!typeNames %in% c('CC','FC','CAT'))
  ncc <- length(wcc)
  if(ncc > 0){
    snames   <- paste('S',c(1:ncc),sep='')
    CCgroups <- FCgroups <- CATgroups <- rep(0,ncc)
    tnames   <- typeNames[wcc]
    s <- ncc
  }
  wcc <- which(typeNames == 'CC')
  ncc <- length(wcc)
  if(ncc > 0){
    ss <- c( (s+1):(s+ncc))
    CCgroups <- c(CCgroups,rep(1,ncc))
    FCgroups <- c(FCgroups,rep(0,ncc))
    tnames   <- c(tnames,rep('CC',ncc))
    snn      <- paste('S',ss,sep='')
    snn[ncc] <- paste(snn[ncc],'other',sep='')
    snames   <- c(snames, snn)
    ngroup <- 1
    s <- max(ss)
  }
  wcc      <- which(typeNames == 'FC')
  ncc <- length(wcc)
  if(ncc > 0){
    ss <- c( (s+1):(s+ncc))
    FCgroups <- c(FCgroups,rep(1,ncc))
    CCgroups <- c(CCgroups,rep(0,ncc))
    tnames   <- c(tnames,rep('FC',ncc))
    snn      <- paste('S',ss,sep='')
    snn[ncc] <- paste(snn[ncc],'other',sep='')
    snames   <- c(snames, snn)
    fgroup <- 1
    s <- max(ss)
  }
  
  CATgroups <- CCgroups*0
  
  if( 'CAT' %in% typeNames ){
    
    wk     <- which(typeNames == 'CAT')
    ncomp  <- length(wk)
    ncat   <- sample(3:4,ncomp,replace=T)
    nall   <- sum(ncat)
    ntot   <- s + nall
    CATgroups <- rep(0,s)
    
    js <- s
    for(j in 1:ncomp){
      js     <- js + 1
      sseq   <- (s+1):(s + ncat[j])
      cj <- paste('S',js,letters[1:ncat[j]],sep='')
      cj[ncat[j]] <- paste('S',js,'other',sep='')
      snames    <- c(snames,cj)
      CATgroups <- c(CATgroups,rep(j,ncat[j]))
      tnames    <- c(tnames,rep('CAT',ncat[j]))
      s <- max(sseq)
    }
    CCgroups <- c(CCgroups,rep(0,sum(ncat)))
    FCgroups <- c(FCgroups,rep(0,sum(ncat)))     
    catCols  <- which(CATgroups > 0)
    cgroup   <- ncomp
  }
  sN     <- length(tnames)
  oo     <- grep('other',snames)
  notOther <- c(1:sN)[-oo]
  
  tmp <- .gjamGetTypes(tnames)
  typeCols <- tmp$typeCols
  typeFull <- tmp$typeFull
  typeCode <- tmp$TYPES[typeCols]
  allTypes <- sort(unique(typeCols))
  typeNames <- tmp$typeNames
  names(typeCols) <- typeNames
  
  if(is.null(x)){
    xm <- .5
    x <- matrix( rnorm(n*Q, xm), n, Q)  
    x[,1] <- 1
  }
  
  beta <- matrix(.1, Q, sN)
  ss   <- diag(.01,sN)    
  
  colnames(beta) <- colnames(ss) <- rownames(ss) <- snames
  wkeep <- numeric(0)
  cnames <- tnames <- character(0)
  
  for(k in allTypes){
    
    wk <- which(typeCols == k)
    nk <- length(wk)
    
    if( typeFull[wk[1]] == 'presenceAbsence' ){
      diag(ss)[wk] <- 1
      beta[,wk]    <- runif(Q*nk,-.8, .8)
      wkeep <- c(wkeep,wk)
      tnames <- c(tnames,typeNames[wk])
      cnames <- c(cnames,colnames(beta)[wk])
    }
    if(typeFull[wk[1]] %in% c('continuous','contAbun')){
      diag(ss)[wk] <- 1
      beta[,wk]    <- runif(Q*nk,-.5, 2)
      wkeep <- c(wkeep,wk)
      tnames <- c(tnames,typeNames[wk])
      cnames <- c(cnames,colnames(beta)[wk])
    }
    if(typeFull[wk[1]] == 'discAbun'){
      diag(ss)[wk] <- 1
      x[,-1] <- x[,-1] + 1
      beta[,wk]    <- runif(Q*nk,-.4, 4)
      wkeep <- c(wkeep,wk)
      tnames <- c(tnames,typeNames[wk])
      cnames <- c(cnames,colnames(beta)[wk])
    }
    if(typeFull[wk[1]] == 'ordinal'){
      diag(ss)[wk] <- 1
      beta[,wk]    <- runif(Q*nk,-.4, 2)
      wkeep <- c(wkeep,wk)
      tnames <- c(tnames,typeNames[wk])
      cnames <- c(cnames,colnames(beta)[wk])
    }
    
    if( typeFull[wk[1]] %in% c('fracComp','countComp','categorical') ){
      
      if(length(wk) < 2)stop('composition data must have at least 2 columns')
      
      ntt <- cgroup
      if( typeFull[wk[1]] == 'fracComp' ){
        ntt <- fgroup
        attr(tnames,'FCgroups') <- FCgroups
      }
      if( typeFull[wk[1]] == 'countComp' ){
        ntt <- ngroup
        attr(tnames,'CCgroups') <- CCgroups
      }
      if( typeFull[wk[1]] == 'categorical' ){
        attr(tnames,'CATgroups') <- CATgroups
      }
      
      for(i in 1:ntt){
        
        if(ntt == 1){   
          wki <- wk
        } else {
          if( typeFull[wk[1]] == 'countComp' )wki <- 
              which(typeCols == k & CCgroups == i)
          if( typeFull[wk[1]] == 'fracComp' )wki <- 
              which(typeCols == k & FCgroups == i)
          if( typeFull[wk[1]] == 'categorical' )wki <- 
              which(typeCols == k & CATgroups == i)
        }
        
        nki    <- length(wki)
        
        if( typeFull[wk[1]] == 'categorical' ){
          
          bb <- matrix( rnorm(Q*nki,0,.5), Q,nki)
          bb[1,] <- bb[1,]*0
          
          for(kk in 1:5){
            
            mu   <- x%*%bb
            w    <- mu
            cols <- apply(w,1,which.max)
            mindex <- cbind( c(1:n),cols )
            
            wmax <- w[mindex]
            ww   <- which(wmax < 0)
            nw   <- length(ww)
            if(nw > 0) w[mindex[ww,]] <- .tnorm(nw,0,10,mu[mindex[ww,]],1)
            
            bb <- solveRcpp(crossprod(x))%*%crossprod(x,w)
          }
          
          keep <- as.numeric( names(table(cols))  )
          wkeep <- c(wkeep,wki[keep])
          tnames <- c(tnames,rep('CAT',length(keep)))
          
          bbb  <- colnames(beta)[wki[keep]]
          if(length(keep) < nki){
            bbb  <- substr(bbb,1,2)
            labs <- c(letters[1:(length(bbb) - 1)],'other')
            bbb  <- paste(bbb,labs,sep='')
          }
          cnames <- c(cnames,bbb)
          beta[,wki] <- bb
          diag(ss)[wk] <- 1
          
        } else {
          
          x <- matrix( rnorm(n*Q, .1), n, Q)  
          x[,1] <- 1
          
          bb <- matrix( rnorm(Q*nki,0,1/nki), Q, nki)
          bb[1,] <- bb[1,]*0
          
          w  <- x%*%bb
          
          for(m in 1:3){
            w1 <- w
            w1[w < 0] <- 0
            w2 <- sweep(w1,1,rowSums(w1),'/')
            w[w >= 0] <- w2[w >= 0]
            bb <- solveRcpp(crossprod(x))%*%crossprod(x,w)
            w  <- x%*%bb
          }
          
          wkeep <- c(wkeep,wki)
          tnames <- c(tnames,typeNames[wki])
          cnames <- c(cnames,colnames(beta)[wki])
          diag(ss)[wk] <- .1/nk^2.5
          beta[,wki] <- bb
        }
      }
    }
  }
  
  S <- length(wkeep)
  beta      <- beta[,wkeep]
  sigma     <- ss[wkeep,wkeep]
  colnames(beta) <- colnames(sigma) <- rownames(sigma) <- cnames
  CCgroups  <-  CCgroups[wkeep] 
  FCgroups  <-  FCgroups[wkeep]
  CATgroups <-  CATgroups[wkeep]
  snames    <- cnames
  other     <- numeric(0)
  notOther  <- c(1:S)
  other     <- grep('other',snames)
  if(length(other) > 0)notOther <- notOther[-other]
  
  list(beta = beta, x = x, sigma = sigma, CCgroups = CCgroups, 
       FCgroups = FCgroups, CATgroups = CATgroups, typeNames = tnames,
       other = other, notOther = notOther, snames = snames)
}

.between <- function(x,lo,hi,ILO = T, IHI = T, OUT=F){
  
  if(length(x) == 0) return( numeric(0) )
  
  if(OUT)return( which(x < lo | x > hi) )
  if(!ILO & !IHI ) return( which(x > lo & x < hi) )
  if(!ILO &  IHI ) return( which(x > lo & x <= hi) )
  if( ILO & !IHI ) return( which(x >= lo & x < hi) )
  if( ILO &  IHI ) return( which(x >= lo & x <= hi) )
        
}        

.simData <- function( n, S, Q, x = NULL, typeNames, nmiss, effort ){
  
  if(length(typeNames) == 1)typeNames <- rep(typeNames,S)
  
  typeNotCat <- typeNames
  
  cgrep <- grep('CAT',typeNames)
  if(length(cgrep) > 0){
    ycat <- vector( mode = 'list', length=length(cgrep) )
    names(ycat) <- paste('CAT',1:length(cgrep),sep='_')
  }
  
    
  cuts <- numeric(0)
  
  tmp    <- .setUpSim(n, S, Q, x, typeNames)
  beta   <- tmp$beta
  x      <- tmp$x
  sig    <- tmp$sigma
  snames <- colnames(beta)
  typeNames <- tmp$typeNames
  other     <- tmp$other
  notOther  <- tmp$notOther
  CCgroups  <- tmp$CCgroups
  FCgroups  <- tmp$FCgroups
  CATgroups <- tmp$CATgroups
  
      
  tmp <- .gjamGetTypes(typeNames)
  typeCols  <- tmp$typeCols
  typeFull  <- tmp$typeFull
  typeCode  <- tmp$TYPES[typeCols]
  allTypes  <- sort(unique(typeCols))
  names(typeCols) <- typeNames
  
  n      <- nrow(x)
  S      <- length(typeNames)
  xnames <- paste('x',1:Q,sep='')
  
  if( !is.null(effort) ){
    ecols <- effort$columns
    emat  <-  effort$values
    if( is.matrix(emat) ){
      emat <- matrix( emat, n, length(ecols) )
      colnames(emat) <- snames[ecols]
    }else{
      emat <- matrix( emat, n, S )
      colnames(emat) <- snames
    }
    effort$values <- emat
  }
  
  SS    <- matrix(1,S,S)
  SS[lower.tri(SS)] <- runif(S*(S - 1)/2,-.98,.98)
  SS[upper.tri(SS)] <- SS[lower.tri(SS)]
  
  sc <- which( typeCode %in% c('FC', 'CC') )
  if( length(sc) > 0 ){
    SS[sc,sc] <- SS[sc,sc]*.0001^2
  }
  
#  RR    <- rmvnormRcpp(S+5, 0, SS) 
  RR    <- cov( .rMVN(S+5, 0, sig) )
  sigma <- .rwish(S+2,RR)/(S + 2)
  
  ####################################3
  #SS    <- cor( RR )
  #SS    <- .cor2Cov(diag(sig),SS)
  #sigma <- .rwish(S+2,SS)/(S + 2)
  ####################################
  
  
  corCols <- which(typeNames %in% c('PA','OC','CAT'))
  if(length(corCols) > 0){
    corSpec <- .cov2Cor(sigma)
    sigma[corCols,corCols] <- corSpec[corCols,corCols]
  }
  
  
  beta[,other] <- 0
  mu <- w <- matrix(0,n,S)
  
  mu[,notOther] <- x%*%beta[,notOther,drop=F]
  w[,notOther]  <- mu[,notOther] + rmvnormRcpp(n, rep(0, length(notOther)),sigma[notOther,notOther]) 
  colnames(w) <- snames
  
  y  <- w
  z  <- w*0
  z[w <= 0]   <- 1
  z[w > 0]    <- 2
  
  for(k in allTypes){
    
    wk <- which(typeCols == k)
    nk <- length(wk) 
    
    if( typeFull[wk[1]] %in% c('fracComp','countComp','categorical') ){
      
      if( typeFull[wk[1]] == 'fracComp' )
        groups <- attr(typeNames,'FCgroups') <- FCgroups
      if( typeFull[wk[1]] == 'countComp' )
        groups <- attr(typeNames,'CCgroups') <- CCgroups
      if( typeFull[wk[1]] == 'categorical' )
        groups <- attr(typeNames,'CATgroups') <- CATgroups
      
      ntt <- max(c(1,groups))
      
      for(i in 1:ntt){
        
        if(ntt == 1){
          wki <- wk
        } else {
          wki <- which(typeCols == k & groups == i)
        }
        nki <- length(wki)
        
        if( typeFull[wk[1]] == 'categorical' ){
          
          wko  <- wki[1:(nki-1)]                  
          wcol <- apply(w[,wko],1,which.max)
          w0   <- which( w[,wko][ cbind( c(1:n),wcol ) ] < 0 )
          if(length(w0) > 0)wcol[w0] <- nki
          
          wtab <- tabulate(wcol)
          if(length(wtab) < nki){
            ww <- rep(0,nki)
            ww[1:length(wtab)] <- wtab
            wtab <- ww
          }
          
          if(min(wtab) < 5){
            wlo <- which(wtab < 5)
            for(s in 1:length(wlo)){
              wro <- sample(n,5)
              wcol[wro] <- wlo[s]
              tmp <- w[wro,wki]
              if(wlo[s] == nki){
                tmp[tmp > -.01] <- -.01   # all values neg
                tmp[,nki] <- .1
              } else {
                mm <- pmax(0,apply(tmp,1,max))
                tmp[,wlo[s]] <- mm + .1
              }
              w[wro,wki] <- tmp
            }
          }
            
          mindex <- cbind(1:n,wcol)
          
          vv <- colnames(w)[wki[wcol]]
          mm <- nchar(vv)
          vv <- substr(vv,3,mm)                  
          
          ycat[[i]] <- vv
          
          yk   <- w[,wki]*0
          yk[ mindex ] <- 1
          y[,wki] <- yk
          z[,wki] <- yk + 1
          
        } else {
          
          noto <- c(1:nki)[-grep('other',snames[wki])]
          ww   <- w[,wki]
          
          bc  <- beta
          wmu <- x%*%beta
          wv  <- w
          
          for(j in 1:5){
            
            w0     <- which(ww < 0)
            ww[w0] <- 0  
            
            yk  <- .gjamCompW2Y(ww,notOther=noto)$ww
            
            yplus <- which(yk > 0)
            yminu <- which(yk < 0)
            
            ww[yplus] <- yk[yplus]
            
            bc[,wki]  <- solveRcpp(crossprod(x))%*%crossprod(x,ww)
            wmu       <- x%*%bc
            ww  <- wmu[,wki] + rmvnormRcpp(n, rep(0, nrow(sigma)), sigma)[,wki]
            if( typeFull[wk[1]] %in% c('countComp','fracComp') ){
              zk <- ww
              w0 <- which( zk < 0 )
              zk[ w0 ] <- 0
              zk <- sweep( zk, 1, rowSums(zk), '/' )
              ww[ww > 0] <- zk[ww > 0]
            }
            bc[,wki]  <- solveRcpp(crossprod(x))%*%crossprod(x,ww)
            wmu       <- x%*%bc
            sigma[wki,wki] <- var(ww - wmu[,wki])
          }
          ww  <- wmu[,wki] + rmvnormRcpp(n, rep(0, nrow(sigma)), sigma)[,wki]
          yk  <- .gjamCompW2Y(ww,notOther=noto)$ww
          ww[ yk > 0 ] <- yk[ yk > 0 ]
          
          zk  <- ww*0 + 1
          zk[w0] <- 0
          w[,wki] <- ww  
          beta[,wki] <- bc[,wki]
          
          if(typeFull[wk[1]] == 'fracComp'){
            
            y[,wki] <- yk
            z[,wki] <- zk
          }
          if( typeFull[wk[1]] == 'countComp' ){
            
            mm <- S*20
            a  <- 4
            b  <- mm/a
            ee <- rpois(n,rgamma(n, shape=a, scale=b))
            yy <- sweep(yk,1,ee,'*')
            
            ww <- ceiling(yy)
            ww[ww < 0] <- 0
            y[,wki] <- ww
            z[,wki] <- ww + 1
          }
        }
      }
    }
    
    if( typeFull[wk[1]] != 'continuous' ) y[,wk][y[,wk] < 0] <- 0  # not cens
    
    if( typeFull[wk[1]] == 'presenceAbsence' ){
      y[,wk] <- z[,wk] - 1       
  #    w2 <- which(w[,wk] < -3)
  #    w[ ,wk][w2] <- -3                  # within 2 standard deviations
  #    w2 <- which(w[,wk] > 3)
  #    w[ ,wk][w2] <- 3
      
    }
    
    if( typeFull[wk[1]] == 'discAbun' ){
      
      wk <- which(typeNames == 'DA')
      
      if( !is.null(effort) ){
        we     <- wk[wk %in% effort$columns]
        ec     <- effort$values[,snames[we]]
        y[,we] <- round( w[,we]*ec )
      } else {
        w0 <- round(w[,wk,drop=F],0)
        y[,wk] <- w0
      }
      y[,wk][y[,wk] < 0] <- 0
      z[,wk]             <- y[,wk] + 1
 
    }
    
    if( typeFull[wk[1]] == 'ordinal' ){
      
      yy   <- w[,wk,drop=F]
      ncut <- 8
      maxw <- floor(max(yy))
      
      cuts  <- t( matrix( c(-Inf, seq(0,(maxw-1),length=(ncut-2)) ,Inf),
                          ncut,nk) )
      rownames(cuts) <- snames[wk]
      
      for(j in 1:nk){
        z[,wk[j]]   <- findInterval(yy[,j],cuts[j,])
      }
      y[,wk] <- z[,wk] - 1
    }
  }
  
  noMore <- F
  
  if( 'categorical' %in% typeFull & noMore){
    
    wss  <- w*0
    wss[,notOther] <- .sqrtMatrix(w[,notOther],sigma[notOther,notOther],
                                      DIVIDE=T)
    css  <- .cov2Cor(sigma[notOther,notOther])
    alpha <- .sqrtMatrix(beta,sigma, DIVIDE=T)
    muss <- x%*%alpha
    
    wk <- which(typeNames == 'CAT')
    wo <- which(wk %in% notOther)
    
    plo  <- w*0 - 5
    phi  <- w*0 + 5
    
    phi[y == 0] <- 0
    plo[y == 1] <- w[y == 1]
    IXX <- solveRcpp(crossprod(x))
    
    for(k in 1:25){
     
      tmp <- .gjamWcatLoop2(y, ws = wss, mus = muss, sgs = css, 
                            notOther, plo, phi, groups = CATgroups)
      wss[,wk]  <- tmp$w[,wk]
      plo       <- tmp$plo
      phi       <- tmp$phi
      beta[,wo] <- IXX%*%crossprod(x,wss[,wo])
      muss[,wo] <- x%*%beta[,wo]
    }
    w[,wo] <- wss[,wo]
  }
      
  sigma[notOther,notOther] <- var(w[,notOther] - x%*%beta[,notOther,drop=F]) 
  
  xnames[1]      <- 'intercept'
  ydata <- data.frame(y)
  colnames(y)    <- snames
  colnames(beta) <- rownames(sigma) <- colnames(sigma) <- snames
  colnames(x)    <- rownames(beta) <- xnames
  
  form <- as.formula( paste('~ ',paste(colnames(x)[-1],collapse='+' )) )
  
  standRows   <- xnames[-1]
  
  tmp <- .getStandX(formula = form, xu = x, standRows )
  betaStn <- tmp$U2S%*%beta
  rownames(betaStn) <- xnames

  typeFrame <- typeNames
  
  if('CAT' %in% typeNames){
    wcat <- grep('CAT',typeNames)
    wnot <- c(1:S)[-wcat] 
    nss  <- length(wnot) + 1
    ncc  <- length(wnot) + length(ycat)
    names(ycat) <- paste('S',nss:ncc,sep='')
    ydata <- as.data.frame(ycat)
    if(length(wnot) > 0)ydata <- cbind(y[,wnot,drop=F],ydata)
    typeFrame <- c(typeNames[wnot], rep('CAT',length(ycat)))
  }
  
  if(nmiss > 0){
    x[ sample(length(x),nmiss) ] <- NA
    x[,1] <- 1
    wmiss <- which(is.na(x),arr.ind=T)
    nmiss <- nrow(wmiss)
  }

  list(formula = form, xdata = data.frame(x), ydata = ydata,
       y = y, w = w,  typeNames = typeFrame, typeY = typeNames, effort = effort,
       trueValues = list(beta = beta, betaStn = betaStn, sigma = sigma, 
                         corSpec = .cov2Cor(sigma), cuts = cuts))
}

.tnorm <- function(n,lo,hi,mu,sig){   

  #normal truncated lo and hi
  
  tiny <- 10e-6

  if(length(lo) == 1 & length(mu) > 1)lo <- rep(lo,length(mu))
  if(length(hi) == 1 & length(mu) > 1)hi <- rep(hi,length(mu))

  q1 <- pnorm(lo,mu,sig)
  q2 <- pnorm(hi,mu,sig) 

  z <- runif(n,q1,q2)
  z <- qnorm(z,mu,sig)
  
  z[z == Inf]  <- lo[z == Inf] + tiny
  z[z == -Inf] <- hi[z == -Inf] - tiny
  z
}

.traitLabel <- function(tname){
  
  tname <- .replaceString(tname,now='soilFactor',new='')
  tname[tname == 'gmPerSeed'] <- 'Seed mass'
  tname[tname == 'gmPerCm']   <- 'Wood dens'
  tname[tname == 'woodSG']    <- 'Wood dens (green)'
  tname[tname == 'maxHt']     <- 'Max ht'
  tname[tname == 'leafN']     <- 'leaf [N]'
  tname[tname == 'leafP']     <- 'leaf [P]'
  tname[tname == "other"]  <- 'Deciduous'
  tname[tname == "broaddeciduous"]  <- 'Deciduous'
  tname[tname == "broadevergreen"]  <- 'BL evergrn'
  tname[tname == "needleevergreen"] <- 'NL evergrn'
  tname[tname == "dioecious"] <- 'Dioecious'
  tname[tname == "u1"] <- 'Slope'
  tname[tname == "u2"] <- 'Aspect 1'
  tname[tname == "u3"] <- 'Aspect 2'
  tname[tname == "ringPorous"] <- 'RP xylem'
  tname[tname == "temp"] <- 'Winter temperature'
  tname[tname == "stdage"] <- 'Stand age'
  for(j in length(tname)){
    tname[j] <- paste(toupper(substring(tname[j], 1, 1)), substring(tname[j], 2),sep = "", collapse = " ")
  }
  tname
}

.updateWishartNoPrior <- function(xx,yy,df,beta=NULL,IXX=NULL,WX=NULL,WIX=NULL,
                                  TRYPRIOR=F){
  #df  <- n - Q + S - 1
  S     <- ncol(yy)
  index <- 0
  XX  <- crossprod(xx)
  IXX <- solveRcpp(XX)

  D  <- diag(1,nrow(xx)) - xx%*%IXX%*%t(xx)
  SS  <-  t(yy)%*%D%*%yy
  testv <- try(chol(SS),T)
  
  if( inherits(testv,'try-error') ){
    tiny <- 1e-8
    SS[SS < tiny] <- tiny
    message('warning: updateWishartNoPrior')
    SS <- crossprod(yy - xx%*%beta) +  diag(diag(SS)*.001)#*nrow(SS)
    SS <- SS + diag(diag(SS)*.1)
    testv <- try(chol(SS),T)
    index <- 1
  }
  SI <- chol2inv(testv)
  
  z  <- matrix(rnorm(df*S),df,S)%*%chol(SI)
  
  sinv  <- crossprod(z)
  sigma <- solveRcpp(sinv)
  list( sigma = sigma, sinv = sinv, indicator = index )
}

.sqrtMatrix <- function(xmat,sigma,DIVIDE=T){
  
  # xmat is n by p
  # sigma is p by p
  
  if(DIVIDE){
    if(length(sigma) == 1)return(xmat/sqrt(sigma))
    return( xmat%*%diag(1/sqrt(diag(sigma))) )
  }
  
  if(length(sigma) == 1)return(xmat*sqrt(sigma))
  xmat%*%diag(sqrt(diag(sigma)) )
}

.yaxisHorizLabs <- function( labels, at=c(1:length(labels)), xshift=.05,
                             col = 'black', pos=NULL){
  
  #add horizontal y axis labels to existing plot
  #pos should be either NULL, 2 (left)
  
  text(par('usr')[3] - xshift*par('usr')[4] - par('usr')[3], y=at,
       labels, xpd=T, pos = pos, col=col)
}

.sampleP <- function(N, avec, bvec, K){
  
  a    <- avec + vapply(1:(N-1), function(k)sum(K == k), 0)
  b    <- bvec + vapply(1:(N-1), function(k)sum(K > k), 0)
  V    <- rbeta((N - 1), a, b)
  p    <- vector("numeric",length=N)
  p[1] <- V[1]
  for(l in 2:(N - 1))p[l] <- prod(1 - V[1:(l - 1)])*V[l]
  p[N] <- prod(1 - V)   
  p
}

.getPars <- function( X, N, r, Y, B, D, Z, sigmaerror, K, pvec,
                     alpha.DP, inSamples,...){      
  
  # Y includes all terms but X%*%beta

  p      <- ncol(X)
  S      <- ncol(Y)
  nn     <- length(inSamples)
  YXB    <- Y[inSamples,] - X[inSamples,]%*%t(B)
  covR   <- solveRcpp( (1/sigmaerror)*crossprod(Z[K,]) + diag(r) ) # Sigma_W
  z1     <- crossprod( Z[K,]/sigmaerror,t( YXB ) )        
  RR     <- rmvnormRcpp(nn, mu = rep(0,r), sigma = covR ) + t(crossprod( covR,z1))
  rndEff <- RR%*%t(Z[K,])
  
  res        <- sum(( YXB - rndEff )^2)
  sigmaerror <- 1/rgamma( 1, shape=(S*nn + 1)/2, rate=res/2 )  
  
  avec <- 1/rgamma(r, shape = ( 2 + r )/2, 
                   rate = ((1/1000000) + 2*diag(solveRcpp(D)) ) )  
  
  D    <- .riwish(df = (2 + r + N - 1), S = (crossprod(Z) + 2*2*diag(1/avec)))
  Z    <- fnZRcpp(kk=K, Yk=Y[inSamples,], Xk=X[drop=F,inSamples,], Dk=D, Bk=B, 
                  Wk=RR, sigmasqk=sigmaerror, Nz=N)
  pmat <- getPmatKRcpp(pveck = pvec,Yk = Y[inSamples,], Zk = Z,
                       Xk = X[drop=F,inSamples,], Bk = B, Wk = RR,
                       sigmasqk = sigmaerror)
  K    <- unlist( apply(pmat, 1, function(px)sample(1:N, size=1, prob=px)) )
  pvec <- .sampleP(N = N, avec = rep(alpha.DP/N,(N-1)),
                   bvec = ((N-1):1)*alpha.DP/N, K = K)  
  
  list(A = Z[K,], D = D, Z = Z, K = K, pvec = pvec, 
       sigmaerror = sigmaerror, rndEff = rndEff)
} 


.wWrapperTime <- function(sampleW, y, timeZero, timeLast, i1, i2, tindex, gindex, uindex,
                          notOther, n, S, REDUCT, RANDOM, TIME, termB, termR, termA, corCols){
  
  function(w, plo, phi, wpropTime, xl, yp, Rmat, Amat, rndEff, groupRandEff, sdg, muw, mub,
           Umat, Vmat, sinv){
    
    # muw predicts w[tindex[,2],] - w[tindex[,1],]
    
    if(RANDOM)muw <- muw + groupRandEff
    
    W <- matrix( .tnorm( n*S,plo,phi,w,wpropTime ),n,S )
    
    W[sampleW == 0] <- y[sampleW == 0]
    
    ii  <- i1
    ni  <- length(ii)
    yp  <- yp*0

    for(im in 1:2){
      
      w[sampleW == 0] <- y[sampleW == 0]
      
      if(im == 2)ii <- i2
      
      i00 <- tindex[ii,1]
      i11 <- tindex[ii,2]
      i22 <- tindex[ii,3]
      t00 <- which(i00 %in% timeZero)
      
      w0 <- which(!i22 %in% c(timeLast+1) )
      i00 <- i00[w0]
      i11 <- i11[w0]
      i22 <- i22[w0]
      
      wn0 <- w[i00,]        # current i00 to predict (i11 - i00)
      wn0[ wn0 < 0 ] <- 0
      wn1 <- w[i11,]        # current i11 to predict (i22 - i11)
      wn1[ wn1 < 0 ] <- 0
      ws1 <- W[i11,]        # proposed i11 predicted by i00 and to predict (i22 - i11)
      ws1[ ws1 < 0 ] <- 0                       
      
      mu00 <- mu11 <- mun1 <- ws1*0
      if(termB){
        mu00 <- mu00 + mub[i00,]
        mu11 <- mun1 <- mu11 + mub[i11,]
      }
      if(termR){
        mu00 <- mu00 + (wn0[,gindex[,'colW']]*xl[i00,gindex[,'rowG']])%*%Rmat
        mu11 <- mu11 + (ws1[,gindex[,'colW']]*xl[i11,gindex[,'rowG']])%*%Rmat
        mun1 <- mun1 + (wn1[,gindex[,'colW']]*xl[i11,gindex[,'rowG']])%*%Rmat
      }
      if(termA){
        mu00 <- mu00 + (wn0[,uindex[,1]]*wn0[,uindex[,2]] )%*%Amat
        mu11 <- mu11 + (ws1[,uindex[,1]]*ws1[,uindex[,2]] )%*%Amat
        mun1 <- mun1 + (wn1[,uindex[,1]]*wn1[,uindex[,2]] )%*%Amat
      }
      if(RANDOM){
        mu00 <- mu00 + groupRandEff[i00,]
        mu11 <- mu11 + groupRandEff[i11,]
        mun1 <- mun1 + groupRandEff[i11,]
      }
      if(REDUCT){
        mu00 <- mu00 + rndEff[i00,]
        mu11 <- mu11 + rndEff[i11,]
        mun1 <- mun1 + rndEff[i11,]
      }
      
      # current
      dw <- w*0
      dw[ i00, ] <- w[ i11, ] - w[ i00 , ]  #W - w; 
      dw[ i11, ] <- w[ i22, ] - w[ i11 , ]
      dw[ timeLast,] <- dw[timeLast - 1, ]
      
      # proposed
      dW <- W*0
      dW[ i00, ] <- W[ i11, ] - w[ i00 , ]  #W - w; 
      dW[ i11, ] <- w[ i22, ] - W[ i11 , ]
      dW[ timeLast,]    <- dW[timeLast - 1, ]
      
      if(REDUCT){
        
        pnow <- dnorm( dw[ i00, ], mu00, sdg, log=T ) +
                dnorm( dw[ i11, ], mun1, sdg, log=T )
        pnew <- dnorm( dW[ i00, ], mu00, sdg, log=T ) + 
                dnorm( dW[ i11, ], mu11, sdg, log=T )
        
        za <- which( runif(length(pnow),0,1) < exp(pnew - pnow) )
        if(length(za) > 0){
          w[i11,][za] <- W[i11,][za]
          ww <- w[i11,]
          ww[ww < 0]  <- 0
          muw[i11,][za] <- mu11[za]
          Umat[i11,]    <- ww[,uindex[,1]]*ww[,uindex[,2]]
          Vmat[i11,]    <- ww[,gindex[,'colW']]*xl[i11,gindex[,'rowG']]
        }
      }else{
        
        pnow <- .dMVN(dw[ i00, ], mu00, sinv=sinv, log=T) + 
                .dMVN(dw[ i11, ], mun1, sinv=sinv, log=T)
        pnew <- .dMVN(dW[ i00, ], mu00, sinv=sinv, log=T) +  
                .dMVN(dW[ i11, ], mu11, sinv=sinv, log=T)    
        
        za <- which( runif(length(pnow),0,1) < exp(pnew - pnow) )
        if(length(za) > 0){
          w[i11[za],] <- W[i11[za],]
          ww          <- w[i11,]
          ww[ ww < 0 ] <- 0 
          muw[i11[za],] <- mu11[za,]
          if(termA)Umat[i11,]    <- ww[,uindex[,1]]*ww[,uindex[,2]]
          if(termR)Vmat[i11,]    <- ww[,gindex[,'colW']]*xl[i11,gindex[,'rowG']]
        }
      }
      W[i11,] <- w[i11,]
    }
    
    # timeZero
    nz <- length(timeZero)
    W  <- matrix( .tnorm(nz*S, plo[timeZero,], phi[timeZero,], w[timeZero,],
                        wpropTime[timeZero,]), nz, S)
    wn1 <- w[timeZero,]
    wn1[ wn1 < 0 ] <- 0
    wn2 <- w[timeZero+1, ]
    wn2[ wn2 < 0 ] <- 0
    ws1 <- W             # proposed i11 predicted by i00 and to predict (i22 - i11)
    ws1[ ws1 < 0 ] <- 0                     
    
    mu11 <- mun1 <- wn1*0
    if(termB){
      mu11 <- mun1 <- mu11 + mub[timeZero,]
    }
    if(termR){
      mu11 <- mu11 + (ws1[,gindex[,'colW']]*xl[timeZero,gindex[,'rowG']])%*%Rmat
      mun1 <- mun1 + (wn1[,gindex[,'colW']]*xl[timeZero,gindex[,'rowG']])%*%Rmat
    }
    if(termA){
      mu11 <- mu11 + (ws1[,uindex[,1]]*ws1[,uindex[,2]] )%*%Amat
      mun1 <- mun1 + (wn1[,uindex[,1]]*wn1[,uindex[,2]] )%*%Amat
    }
    if(RANDOM){
      mu11 <- mu11 + groupRandEff[timeZero,]
      mun1 <- mun1 + groupRandEff[timeZero,]
    }
    if(REDUCT){
      mu11 <- mu11 + rndEff[timeZero,]
      mun1 <- mun1 + rndEff[timeZero,]
    }
    dw <- wn2 - wn1
    dW <- wn2 - ws1
    
    if(REDUCT){
      pnow <- dnorm( dw, mun1, sdg, log=T)
      pnew <- dnorm( dW, mu11, sdg, log=T)
      za   <- which( runif(length(pnow),0,1) < exp(pnew - pnow) )
      if(length(za) > 0){
        w[timeZero,][za]   <- W[za]
        ww <- w[timeZero,]
        ww[ww < 0]  <- 0
        muw[timeZero,][za] <- mu11[za]
        Umat[timeZero,] <- ww[,uindex[,1]]*ww[,uindex[,2]]
        Vmat[timeZero,] <- ww[,gindex[,'colW']]*xl[timeZero,gindex[,'rowG']]
      }
    }else{
      pnow <- .dMVN( dw, mun1, sinv=sinv, log=T)
      pnew <- .dMVN( dW, mu11, sinv=sinv, log=T)
      za   <- which( runif(length(pnow),0,1) < exp(pnew - pnow) )
      if(length(za) > 0){
        w[timeZero[za],]   <- W[za,]
        ww <- w[timeZero,]
        ww[ww < 0]  <- 0
        muw[timeZero[za],] <- mu11[za,]
        Umat[timeZero,] <- ww[,uindex[,1]]*ww[,uindex[,2]]
        Vmat[timeZero,] <- ww[,gindex[,'colW']]*xl[timeZero,gindex[,'rowG']]
      }
    }
    
    # yp is on variance scale, not correlation scale
    mu <- muw[,notOther]
    mu[tindex[,2],] <- w[tindex[,1],notOther] + muw[tindex[,1],] 
    mu[timeZero,]   <- w[timeZero,notOther]  
    if(REDUCT){
      yp <- matrix(rnorm(n*S,mu,sdg),n,S)
    }else{
      yp[,notOther] <- .rMVN(n, mu, sinv = sinv[notOther,notOther]) 
    }
    
    list(Umat = Umat, Vmat = Vmat, w = w, muw = muw, yp = yp)
  }
}

.wWrapper <- function(REDUCT, RANDOM, S, effMat, corCols, notCorCols, typeNames, 
                      typeFull, typeCols, 
                      allTypes, holdoutN, holdoutIndex, censor, 
                      censorCA, censorDA, censorCON, notOther, sampleW, 
                      byRow, byCol,
                      indexW, ploHold, phiHold, sampleWhold, inSamp){
  if(REDUCT){
    
    function(rows, x, w, y, bg, sg, alpha, cutg, plo, phi, 
             rndEff, groupRandEff, sigmaerror, wHold){
      
      n    <- nrow(y)
      w0   <- which(sampleW == 1)
      SC   <- ncol(y)
      scol <- c(1:S)
      sigvec <- rep(sigmaerror,S)

      if(holdoutN > 0){ # in-sample to predict X out-of-sample
        wHold <- w[drop=F,holdoutIndex,] 
      }
      
      yPredict  <-  w*0
      SN <- length(notCorCols)
      
      if( length(notCorCols) > 0 ){ ###### covariance scale
        
        mue    <- x%*%bg
        if(RANDOM)mue <- mue + groupRandEff
        muf    <- mue + rndEff

        w[w0]  <- .tnorm(length(w0), plo[w0], phi[w0], muf[w0], sqrt(sigmaerror))
        w[-w0] <- y[-w0]          
        
        if(holdoutN < n){   # in-sample prediction, known RE
          yPredict[,notCorCols] <- rnorm(n*SN, muf[,notCorCols], sqrt(sigmaerror))
        }
        
        if( holdoutN > 0 ){ # in-sample for holdouts to predict X out-of-sample
          
          # in-sample with RE
          if(holdoutN < n){
            wHold[,notCorCols] <- 
              matrix( .tnorm(holdoutN*SN, as.vector(ploHold[,notCorCols]), 
                             as.vector(phiHold[,notCorCols]),
                             as.vector(muf[drop=F,holdoutIndex,notCorCols] ),
                             sqrt(sigmaerror)),holdoutN,SN) 
          }
          # marginalized RE out-of-sample
          w[holdoutIndex,notOther] <- yPredict[holdoutIndex,notOther] <-
            .rMVN(holdoutN,mue[holdoutIndex,notOther],
                  sg[notOther,notOther]) #out-of-sample RE
        }
      }
      
      if( length(corCols) > 0 ){   # corr scale
        
        css  <- sg*0
        css[notOther,notOther]  <- .cov2Cor(sg[notOther,notOther])
        
        muo <- x%*%alpha
        if(RANDOM)muo <- muo + groupRandEff
        
        if(holdoutN < n){
          mur <- muo 
          if(length(rndEff) > 1)mur <- mur + .sqrtMatrix(rndEff,sg,DIVIDE=T)
          SC  <- length(corCols)
          
          # includes RE on correlation scale
          w[,corCols] <- matrix( .tnorm(n*SC, as.vector(t(plo[,corCols])), 
                                        as.vector(t(phi[,corCols])), 
                                        as.vector(t(mur[,corCols])),1),
                                 n,SC, byrow=T) 
          yPredict[,corCols] <- rnorm(n*SC,mur[,corCols],1)
        }                              
        if(holdoutN > 0){ # out-of-sample
          if(holdoutN < n){
            wHold[,corCols] <- matrix( .tnorm(holdoutN*SC, 
                                              as.vector(ploHold[,corCols]), 
                                              as.vector(phiHold[,corCols]),
                                              as.vector(t(mur[holdoutIndex,corCols])),
                                              1),holdoutN,SC) 
        }
           w[holdoutIndex,corCols] <- yPredict[holdoutIndex,corCols]  <- 
                                    rmvnormRcpp(holdoutN,rep(0,length(corCols)),
                                                css[corCols,corCols]) + muo
      }
    }
      
      if( !is.null(sampleW) )w[sampleW == 0] <- y[sampleW == 0]
      
      if( holdoutN > 0 ){   # in-sample to sample X out-out-sample
        wHold[sampleWhold == 0] <- y[holdoutIndex,][sampleWhold == 0]  
      }
      
      FCgroups  <- attr(typeNames,'FCgroups')
      CCgroups  <- attr(typeNames,'CCgroups')
      CATgroups <- attr(typeNames,'CATgroups')
      
      for(k in allTypes){
        
        wk <- which(typeCols == k)
        wo <- which(wk %in% notOther)
        nk <- length(wk)
        wu <- which(typeCols[notOther] == k)
        wp <- w[, wk, drop=F]
        yp <- yPredict[, wk, drop=F]
        
        groups <- NULL
        if(typeFull[wk[1]] == 'countComp')  groups <- CCgroups[wk]
        if(typeFull[wk[1]] == 'fracComp')   groups <- FCgroups[wk]
        if( typeFull[wk[1]] == 'categorical' ){
          groups <- CATgroups[wk]
          
          if(holdoutN < n){
            tmp <- .gjamWcatLoop2(y, ws = wp, mus = muf, sgs = sigvec, 
                                  notOther = notOther, plo, phi, 
                                  groups = CATgroups, REDUCT=T)
            wp[,wo] <- tmp$w[,wo]
            plo     <- tmp$plo
            phi     <- tmp$phi
          }
          
          if(holdoutN > 0){
            ws <- w[, wk, drop=F]
            ws[holdoutIndex,] <- wHold[, wk, drop=F]
            if(holdoutN < n)wHold[,wo] <- .gjamWcatLoop2(y, ws, mus = muf, 
                                                         sgs = sigvec, 
                                         notOther = notOther, ploHold, phiHold, 
                                         groups = CATgroups, REDUCT=T) 
          }
        }
        
        glist <- list(wo = wo, type = typeFull[wk[1]], yy = y[,wk,drop=F],
                      wq = wp, yq = yp, cutg = cutg, censor = censor,
                      censorCA = censorCA, censorDA = censorDA, censorCON = censorCON,
                      eff = effMat[rows,wk,drop=F],groups = groups, k = k, 
                      typeCols = typeCols, notOther = notOther, wk = wk, 
                      sampW = sampleW[,wk])
        
        if( holdoutN < n ){
          
          tmp <- .gjamWLoopTypes( glist )  # if PA, yPredict on probit scale
          w[,wk]              <- tmp[[1]]
          yPredict[inSamp,wk] <- tmp[[2]][inSamp,]  # not holdouts
        }
        if( holdoutN > 0 ){
          
          glist$wq <- wHold[,wk,drop=F]
          glist$yq <- yPredict[holdoutIndex, wk, drop=F]
          glist$yy <- y[holdoutIndex,wk,drop=F]
          glist$eff <- effMat[holdoutIndex, wk, drop=F]
          glist$sampW <- sampleW[,wk]
          
          tmp <- .gjamWLoopTypes( glist )
          
          if(holdoutN < n)wHold[,wk] <- tmp[[1]]  #in-sample for x prediction
          yPredict[holdoutIndex,wk]  <- tmp[[2]]  #out-of-sample prediction
        }
        yPredict[,wk] <- .censorValues(censor,y,yPredict)[,wk]
      }
      
      if(!is.null(sampleW))w[sampleW[rows,] == 0] <- y[sampleW[rows,] == 0]
      if(holdoutN > 0){
        wHold[sampleWhold == 0] <- y[holdoutIndex,][sampleWhold == 0]
      }
      
      list(w = w, wHold = wHold, yp = yPredict, plo = plo, phi = phi )
    }
    
  } else {
    
    function(rows, x, w, y, bg, sg, alpha, cutg, plo, phi, 
             rndEff  = NULL, groupRandEff, sigmaerror = NULL, wHold){
      
      # for holdouts: wHold - w in-sample for sampling x out-out-sample
      #               w[holdoutIndex,] - predict out-of-sample
      
      n     <- nrow(y)
      sampW <- sampleW[rows,notOther]
      w[sampleW[rows,] == 0] <- y[sampleW[rows,] == 0]
      
      if(holdoutN > 0){
        wHold[sampleWhold == 0] <- y[holdoutIndex,][sampleWhold == 0]
      }
      
      yPredict <- w*0
      muw <- x%*%bg
    
      if( length(notCorCols) > 0 ){
        if(RANDOM)muw <- muw + groupRandEff
        yPredict[,notOther] <- rmvnormRcpp(n,rep(0,length(notOther)),
                                           sg[notOther,notOther]) + muw[,notOther]
      }
      
      if( length(corCols) > 0 ){    #expanded w on this scale
        wss  <- w*0
        css  <- .cov2Cor(sg[notOther,notOther])
        muss <- x%*%alpha
        if(RANDOM)muss <- muss + groupRandEff
   #     muw[,corCols] <- muss[,corCols]
        
        ypred <- yPredict
        ypred[,notOther]   <- rmvnormRcpp(n,rep(0,length(notOther)),css) + 
                                 muss[,notOther]
        yPredict[,corCols] <- ypred[,corCols]
      } 
      
      FCgroups  <- attr(typeNames,'FCgroups')
      CCgroups  <- attr(typeNames,'CCgroups')
      CATgroups <- attr(typeNames,'CATgroups')
      
      for(k in allTypes){       # conditional sampling here
        
        wk <- which(typeCols == k)
        nk <- length(wk)
        wo <- which(wk %in% notOther)
        wu <- which(typeCols[notOther] == k)
        wp <- w[, wk, drop=F]
        yq <- yPredict[, wk, drop=F]
        
        if( typeFull[wk[1]] %in% c('presenceAbsence','ordinal') ) {
    
          wss[,notOther] <- .sqrtMatrix(w[,notOther],sg[notOther,notOther],
                                        DIVIDE=T)
          llist <- list(ws = wss[,notOther], mus = muss[,notOther], 
                        sgs = css, wkk = wu, 
                        lo = plo[,notOther], hi = phi[,notOther],
                        sampW = sampW, indexW = indexW)
          wp[,wo] <- .gjamWLoop( llist )[,wu] #########################
          
          if( holdoutN > 0 ){
            if( holdoutN < n ){
              llist <- list(ws = wss[drop=F,holdoutIndex,notOther], 
                            mus = muss[drop=F,holdoutIndex,notOther], 
                            sgs = css, wkk = wu, 
                            lo = ploHold[drop=F,,notOther], 
                            hi = phiHold[drop=F,,notOther],
                            sampW = sampleWhold[,notOther], indexW=wo)
              wHold[,wo] <- .gjamWLoop( llist )[,wu] 
            }
            wp[holdoutIndex,wo] <- yq[holdoutIndex,wo]
          }
        }
        
        if( typeFull[wk[1]] == 'categorical' ){
          
          wss[,notOther] <- .sqrtMatrix(w[,notOther],sg[notOther,notOther],
                                            DIVIDE=T)
    #      yy  <- y
          if(holdoutN > 0)yy[holdoutIndex,] <- yq[holdoutIndex,]
          tmp <- .gjamWcatLoop2(y, ws = wss, mus = muss, sgs = css, 
                                notOther, plo, phi, groups = CATgroups)
          wp      <- tmp$w[,wk]
          plo     <- tmp$plo
          phi     <- tmp$phi
          
          if(holdoutN > 0){
            if(holdoutN < n){
              wHold[,wk] <- .gjamWcatLoop2(yq[drop=F,holdoutIndex,],
                                           wss[drop=F,holdoutIndex,], 
                                           muss[drop=F,holdoutIndex,], sgs = css, 
                                           notOther, ploHold, phiHold, 
                                           groups = CATgroups)$w[,wk]
            }
            wp[holdoutIndex,wo] <- yq[holdoutIndex,wo]
          }
        }
        
        if( typeFull[wk[1]] == 'fracComp' ){
          
          llist <- list(ws = w[,notOther], mus = muw[,notOther],
                        sgs = sg[notOther,notOther], wkk = wu,
                        lo = plo[,notOther], hi = phi[,notOther],sampW = sampW, 
                        indexW = indexW, 
                        groups = FCgroups, byCol= byCol, byRow = byRow)
          wp[,wo] <- .gjamWLoop( llist )[,wu] 
          
          if(holdoutN > 0){
            if(holdoutN < n){
              llist <- list(ws = w[drop=F,holdoutIndex,notOther], 
                            mus = muw[drop=F,holdoutIndex,notOther], 
                            sgs = sg[notOther,notOther], wkk = wu,
                            lo = ploHold[drop=F,,notOther],
                            hi = phiHold[drop=F,,notOther],
                            sampW = sampleWhold[,notOther], indexW = wo, 
                            groups = FCgroups, 
                            byCol = byCol, byRow = byRow)
              wHold[,wo] <- .gjamWLoop( llist )[,wu] 
              wp[holdoutIndex,wo] <- yq[holdoutIndex,wo]
            }
          }
          w[,wo]        <- wp[,wo]
        }
        
        if( !typeFull[wk[1]] %in% c('presenceAbsence','ordinal','categorical','fracComp') ){
          
          llist <- list(ws = w[,notOther], mus = muw[,notOther],
                        sgs = sg[notOther,notOther], wkk = wu,
                        lo = plo[,notOther], hi = phi[,notOther],sampW = sampW, 
                        indexW = indexW, byCol= byCol, byRow = byRow)
          wp[,wo] <- .gjamWLoop( llist )[,wu] 
          
          if(holdoutN > 0){
            if(holdoutN < n){
              llist <- list(ws = w[drop=F,holdoutIndex,notOther], 
                            mus = muw[drop=F,holdoutIndex,notOther], 
                            sgs = sg[notOther,notOther], wkk = wu,
                            lo = ploHold[drop=F,,notOther],
                            hi = phiHold[drop=F,,notOther],
                            sampW = sampleWhold[,notOther], indexW = wo, 
                            byCol = byCol, byRow = byRow)
              wHold[,wo] <- .gjamWLoop( llist )[,wu] 
              wp[holdoutIndex,wo] <- yq[holdoutIndex,wo]
            }
          }
        }
        
        # yPredict is on w scale, change to y scale
        
        groups <- NULL
        if(typeFull[wk[1]] == 'countComp')  groups <- CCgroups[wk]
        if(typeFull[wk[1]] == 'fracComp')   groups <- FCgroups[wk]
        if(typeFull[wk[1]] == 'categorical')groups <- CATgroups[wk]
        
        glist <- list(wo = wo, type = typeFull[wk[1]], yy = y[,wk,drop=F],
                      wq = wp, yq = yq, cutg = cutg, censor = censor,
                      censorCA = censorCA, censorDA = censorDA, 
                      censorCON = censorCON,
                      eff = effMat[rows,wk,drop=F], groups = groups, k = k, 
                      typeCols = typeCols, notOther = notOther, wk = wk, 
                      sampW = sampleW[,wk])
        tmp <- .gjamWLoopTypes( glist ) #########################
        if( typeFull[wk[1]] != 'fracComp' )w[,wk] <- tmp[[1]]
        yPredict[,wk] <- tmp[[2]]
        
    #    if(holdoutN > 0){
          
          # predict for actual sample size
    #      ys <- yq[holdoutIndex,,drop=F]
    #      ys[ys < 0] <- 0
    #      ys <- rowSums(y[holdoutIndex,wk,drop=F])*ys

    #      glist <- list(wo = wo, type = typeFull[wk[1]], yy = ys, 
    #                    wq = wp[drop=F,holdoutIndex,], yq = yq[drop=F,holdoutIndex,], 
    #                    cutg = cutg, censor = censor, censorCA = censorCA, 
    #                    censorDA = censorDA, censorCON = censorCON, 
    #                    eff = effMat[drop=F,holdoutIndex,wk], groups = groups, 
    #                    k = k, typeCols = typeCols, notOther = notOther, wk = wk, 
    #                    sampW = sampleW[drop=F,holdoutIndex,wk] )
    #      tmp <- .gjamWLoopTypes( glist )
    #      w[holdoutIndex,wk] <- tmp[[1]]
    #      yPredict[holdoutIndex,wk] <- tmp[[2]]    
    #    }
        
        yPredict[,wk] <- .censorValues(censor, y, yPredict)[,wk]
      }
      
      if( !is.null(sampleW) )w[sampleW[rows,] == 0] <- y[sampleW[rows,] == 0]
      
      list(w = w, wHold = wHold, yp = yPredict, plo = plo, phi = phi )
    }
  }
}

.binaryScore <- function(p, x){
  
  #brier and logarithmic score, prediction prob p, event x = 0 or 1
  
  a <- mean((x - p)^2)
  b   <- -mean( x*log(p) + (1 - x)*log(1 - p))
    
  list(brierScore = a, logScore = b)
}
    

.betaWrapper <- function(REDUCT, TIME, notOther, betaLim=50){
  
  # betaLim - outer prior limit for beta
  
  if(REDUCT){
    
    function(X, Y, sig, beta, PRIOR, lo, hi, wF = NULL, rows=NULL, pattern=NULL, ...){
      
      S  <- ncol(Y)
      w0 <- which(colSums(X) == 0)
      if(length(w0) > 0){
        X <- X[,-w0]
        beta <- beta[-w0,]
        rows[rows %in% w0] <- NA
      }
      
      XX   <- crossprod(X)
      IXX  <- try( solveRcpp(XX), T )
      if( inherits(IXX,'try-error') ){
        diag(XX) <- diag(XX) + 1.001*diag(XX)
        IXX <- solveRcpp(XX)
      }
      
      omega <- sig*IXX
      muB   <- t(omega%*%crossprod((1/sig)*X, Y))
      
      if( !PRIOR ){
        
        B   <- rmvnormRcpp( S, rep(0,nrow(omega)), omega) + muB
        
        ws <- which(abs(B) > betaLim, arr.ind=T)
        
        if(length(ws) > 0){
          ws <- unique(ws[,1])
          bs <- B[drop=F,ws,]
          B[ws,] <- .tnormMVNmatrix(avec = bs, muvec = muB[drop=F,ws,], 
                                    smat = omega, lo = bs*0 - betaLim, 
                                    hi = bs*0 + betaLim)
        }
        return(t(B))
      }
      
      if(!TIME){
        
        tmp <- .tnormMVNmatrix( avec = t(beta), muvec = muB, 
                                smat = omega, lo = t(lo), 
                                hi = t(hi) )
        return( t(tmp) )
      }
      
      B    <- beta                             # REDUCT & TIME
      muB  <- t(muB)
      sinv <- XX/sig
      QX   <- ncol(sinv)
      
      for( k in pattern ){             # responses independent
        
        wk <- wF[ drop=F, wF[,2] == k, ]       # locations in beta affect y[,k]
        if(length(wk) == 0)next
        
        l  <- matrix(lo[ wk ], 1 )
        h  <- matrix(hi[ wk ], 1 )
        wc <- wk[,1]                           # non-zero
        wp <- c(1:QX)[-wc]                     # zeros
        mc <- matrix( muB[wc], ncol=1)
        mp <- matrix( muB[wp], ncol=1)   
        
        s11  <- omega[drop=F, wc,wp]%*%sinv[drop=F, wp,wp]
        mcon <- mc - s11%*%mp
        Mcon <- solveRcpp( sinv[drop=F, wc,wc] )
        tmp  <- .tnormMVNmatrix(avec = matrix(B[ wk ], 1), muvec = t(mcon), 
                               smat = Mcon, lo = l, hi = h)
        B[ wk ] <- tmp
      }
      return( B )
    }
    
  }else{          # !REDUCT
    
    function(X, Y, sig, beta, PRIOR, lo, hi, rows = NULL, pattern = NULL,
             sinv = NULL, wF, ...){
      
      if( !PRIOR ){
        
        XX  <- crossprod(X)
        IXX <- chol2inv(chol( XX ) )
        WX  <- crossprod(X,Y)
        WIX <- IXX%*%WX
        bg  <- matrix( rmvnormRcpp(1,as.vector(WIX),
                             kronecker(sig, IXX)), nrow(IXX), ncol(WIX) )
        return(bg)
      }
      
      # !REDUCT & PRIOR
      
      wc <- which( !is.na(lo) & lo < hi )    # if no interval, assume zero
      wp <- c(1:length(lo))[-wc]             # is.na(lo) or lo >= hi
      
      XX  <- crossprod(X)
      IXX <- chol2inv( chol( XX ) )
      WX  <- crossprod(X,Y)
      MU  <- matrix( IXX%*%WX, ncol = 1 )
      MM  <- kronecker( sig, IXX )
      
      if( length(wp) > 0 ){                            # condition on unsampled coeffs = 0
        
        if( length(wp) > length(wc) ){                 # matrix is sparse

          if( is.null(sinv) )sinv <- solveRcpp(sig)
          CC <- kronecker( sinv, XX )                  # note reverse order and inverse
          IC <- solveRcpp(CC[wc,wc])                   # M_{wc|wp}
          IM <- CC[wp,wp] - CC[wp,wc]%*%IC%*%CC[wc,wp] # inverse of M_{wp,wp} -> large
          MU <- t( MU[wc] - MM[wc,wp]%*%IM%*%MU[wp] )
          MM <- IC
          
        } else {                                       # not sparse
          M1   <- MM[wc,wp]%*%solveRcpp(MM[wp,wp])
          MU   <- t( MU[wc] - M1%*%MU[wp] )
          MM   <- MM[wc,wc] - M1%*%MM[wp,wc]
        }
      } else {
        MU <- t(MU)
      }
      
      beta[wc] <- .tnormMVNmatrix(avec = matrix(beta[wc],1), muvec = MU, 
                                  smat = MM, lo = matrix(lo[wc],1), 
                                  hi = matrix(hi[wc],1))
      return(beta)
    }
  }
}

.paramWrapper <- function(REDUCT, inSamples,SS){   
  
  if(REDUCT){    
    
    function( X, beta, Y, otherpar ){
      
      N  <- otherpar$N
      r  <- otherpar$r
      D  <- otherpar$D
      Z  <- otherpar$Z
      sigmaerror <- otherpar$sigmaerror
      K          <- otherpar$K
      pvec       <- otherpar$pvec
      alpha.DP   <- otherpar$alpha.DP
      tmp        <- .getPars(X = X, N = N, r = r, Y = Y, B = t(beta), 
                             D = D, Z = Z, sigmaerror = sigmaerror,
                             K = K, pvec = pvec, alpha.DP = alpha.DP,
                             inSamples = inSamples, SELECT = F)
      
      sg <- with(tmp, .expandSigma(sigma = tmp$sigmaerror, SS, Z = tmp$Z, 
                                   K = tmp$K, REDUCT=T))
      
      otherpar <- list(A = tmp$A, N = N, r = r, D = tmp$D, Z = tmp$Z, 
                       sigmaerror = tmp$sigmaerror,
                       pvec = tmp$pvec, K = tmp$K, alpha.DP = alpha.DP)
      
      return(list(sg = sg, rndEff = tmp$rndEff, otherpar = otherpar))
    }
    
  } else {
    
    function(x, beta,Y,otherpar){
      
      sigmaDf  <- otherpar$sigmaDf
      XX  <- crossprod(x[inSamples,])
      IXX <- solveRcpp(XX)
      WX  <- crossprod(x[inSamples,], Y[inSamples,])
      WIX <- IXX%*%WX
      
      sg <- .updateWishartNoPrior( x[drop=F,inSamples,], Y[inSamples,], sigmaDf,
                                   beta = beta, IXX = IXX, WX = WX, WIX = WIX,
                                   TRYPRIOR = T)$sigma
      otherpar=list(Z = NA, K = NA, sigmaDf = sigmaDf)
      
      return(list(sg = sg, otherpar = otherpar))
    }
  }
}

.rwish <- function(df,SS){
  z  <- matrix(rnorm(df*nrow(SS)),df,nrow(SS))%*%chol(SS)
  crossprod(z)
}

.riwish <- function(df,S){
  solveRcpp(.rwish(df,solveRcpp(S)))
}

.expandSigmaChains <- function(snames, sgibbs, otherpar, 
                               simIndex = sample(nrow(sgibbs),50,replace=T), 
                               sigErrGibbs, kgibbs=NULL, 
                               REDUCT=F, CHAINSONLY=F, verbose){
  tiny <- 1e-8
  
  S <- otherpar$S
  K <- otherpar$K
  N <- otherpar$N
  r <- otherpar$r
  if(length(simIndex) > 1000)simIndex <- sample(simIndex,1000)
  ns     <- length(simIndex)
  xnames <- otherpar$xnames
  
  if( CHAINSONLY & !REDUCT ){  #only return expanded sgibbs
    
    imat   <- matrix(1:(S*S),S,S)
    jmat   <- matrix(1:(S*S),S,S,byrow=T)
    tmp    <- matrix(NA,nrow(sgibbs),S*S)
    sindex <- imat[lower.tri(imat,diag=T)]
    tmp[,sindex] <- sgibbs
    sindex <- jmat[lower.tri(imat,diag=T)]
    tmp[,sindex] <- sgibbs
    
    sMu <- matrix( colMeans(tmp),S,S)
    sSe <- matrix( apply(tmp,2,sd),S,S)
    
    rownames(sMu) <- colnames(sMu) <- snames
    rownames(sSe) <- colnames(sSe) <- snames
    
    chainList <- list(cchain = NULL, schain = tmp, kchain = NULL)
    
    return( list(chainList = chainList, rMu = NULL, rSe = NULL, 
                 sMu = sMu, sSe = sSe) )
  }
  
  # summarize chains
  
  other    <- grep('other',snames)
  notOther <- c(1:S)
  if(length(other) > 0)notOther <- notOther[-other]
  
  Kindex <- which(lower.tri( diag(S),diag=T ) )
  kchain <- NULL
  
  schain <- cchain <- matrix(0,ns,length(Kindex))
  colnames(schain) <- colnames(cchain) <- .multivarChainNames(snames,snames)[Kindex]
  
  if( REDUCT ){
    kchain <- matrix(0, ns, ncol(kgibbs))
    toConsole('expanding covariance chains', verbose = verbose)
  }
  
  snames <- otherpar$snames
  s1 <- diag(S)*0
  s2 <- r1 <- r2 <- s1
  
  pbar <- txtProgressBar(min=1,max=ns,style=1)
  
  sinvPlus <-  sinvMinus <- matrix(0,S,S)   # different from zero
  
  k <- 1
  
  for(j in simIndex){
    
    if(REDUCT){
      Z  <- matrix(sgibbs[j,],N,r)
      ss <- .expandSigma(sigErrGibbs[j], S, Z = Z, kgibbs[j,], REDUCT = TRUE)
      si <- invWbyRcpp(sigErrGibbs[j], Z[kgibbs[j,],])
      cc <- .cov2Cor(ss)
      dc <- diag(sqrt(diag(ss)))
      ci <- dc%*%si%*%dc
    } else {
      ss <- .expandSigma(sgibbs[j,], S = S, REDUCT = FALSE)
      si <- ci <- diag(1,S)
      si[notOther,notOther] <- solveRcpp(ss[notOther,notOther])
      cc <- .cov2Cor(ss)
      ci[notOther,notOther] <- solveRcpp(cc[notOther,notOther])
    }
    
    s1 <- s1 + ss
    s2 <- s2 + ss^2
    r1 <- r1 + cc
    r2 <- r2 + cc^2
    
    schain[k,]    <- ss[Kindex]
    cchain[k,]    <- cc[Kindex]
    if(REDUCT)kchain[k,] <- kgibbs[j,]
    
    sinvPlus[si > 0]  <- sinvPlus[si > 0] + 1
    sinvMinus[si < 0] <- sinvMinus[si < 0] + 1
    
    setTxtProgressBar(pbar,k)
    k <- k + 1
  }
  diag(sinvPlus) <- diag(sinvMinus) <- 0
  sigInvPos <- which(sinvPlus > .95*length(simIndex),arr.ind=T)
  sigInvNeg <- which(sinvMinus > .95*length(simIndex),arr.ind=T)
  
  ssi <- sort( unique(c( sigInvPos[,1], sigInvNeg[,1]) ) )

  ms <- sums2meanSd( s1, s2, ns )
  sMu <- ms$mean
  sSe <- ms$sd
  ms <- sums2meanSd( r1, r2, ns )
  rMu <- ms$mean
  rSe <- ms$sd
  
  rownames(sMu) <- colnames(sMu) <- rownames(rMu) <- colnames(rMu) <- snames
  rownames(sSe) <- colnames(sSe) <- rownames(rSe) <- colnames(rSe) <- snames
  colnames(cchain) <- colnames(schain)
  
  chainList <- list(cchain = cchain, schain = schain, kchain = kchain)
  
  list(chainList = chainList, rMu = rMu, rSe = rSe, 
       sMu = sMu, sSe = sSe)
}

.expandSigma <- function(sigma, S, Z = NULL, K = NULL, REDUCT = F){
  
  if(REDUCT) return( sigma*diag(S) + tcrossprod(Z[K,]) )
  
  ss <- diag(S)
  ss[lower.tri(ss,diag=T)] <- sigma
  ss[upper.tri(ss)] <- t(ss)[upper.tri(ss)]
  ss
}

.ordTraitsFromWts <- function(yWt,ordTraits){
  
  # yWt - n by S species weights
  # ordTraits - S by p ordinal traits
  # returns n by p modal ordinal values
  
  if(!is.matrix(ordTraits))ordTraits <- matrix(ordTraits)
  
  n <- nrow(yWt)
  s <- ncol(yWt)
  
  ii <- rep(c(1:n),s)
  omat <- matrix(NA,n,ncol(ordTraits))
  
  for(j in 1:ncol(ordTraits)){
    
    PLUS <- F
    
    oj  <- ordTraits[,j]
    if(min(oj) < 0)stop('ordinal scores cannot be < 0')
    if(min(oj) == 0){
      PLUS <- T
      oj   <- oj + 1
    }
    
    rj  <- range(oj, na.rm=T)
    mm  <- matrix(0, n, rj[2] )
    jj  <- as.vector( matrix(oj, n, s, byrow=T) )
    tmp <- .byGJAM(as.vector(yWt),ii,jj,mm,mm,fun='sum')
    w0  <- which( apply(tmp,1,sum) == 0)
    
    m1  <- apply(tmp,1,which.max)
    m1  <- (rj[1]:rj[2])[m1]
    if(PLUS)m1 <- m1 - 1
    omat[,j] <- m1
    if(length(w0) > 0)omat[w0,j] <- 0
  }
  colnames(omat) <- colnames(ordTraits)
  omat
}

.incidence2Grid <- function(specs, lonLat, nx = NULL, ny = NULL, dx = NULL, 
                            dy = NULL, predGrid = NULL, effortOnly=TRUE){
  
  # must have either ngrid X 2 prediction grid, or 
  #   numbers of points nx, ny, or
  #   densities of points dx, dy
  
  ngrid <- length(predGrid)
  mapx  <- range(lonLat[,1])
  mapy  <- range(lonLat[,2])
  
  specs  <- as.character(specs)
  
  ynames <- sort(unique(specs))
  nspec  <- length(ynames)
  jj     <- match(specs,ynames)
  
  if(ngrid == 0){
    if(!is.null(dx)){
      xseq <- seq(mapx[1], mapx[2], by = dx)
      yseq <- seq(mapy[1], mapy[2], by = dy)
    } else {
      xseq <- seq(mapx[1], mapx[2], length = nx)
      yseq <- seq(mapy[1], mapy[2], length = ny)
    }
    predGrid <- as.matrix( expand.grid(lon = xseq, lat = yseq) )
    ngrid    <- nrow(predGrid)
  }
  
  ii <- RANN::nn2(predGrid, lonLat, k = 1  )$nn.idx
  mm <- matrix(0, ngrid, nspec )
  
  gridBySpec <- .byGJAM(ii*0 + 1, ii, jj, mm, mm, fun='sum')
  colnames(gridBySpec) <- ynames
  effort <- rowSums(gridBySpec)
  
  if(effortOnly){
    wk <- which(effort > 0)
    effort     <- effort[wk]
    gridBySpec <- gridBySpec[wk,]
    predGrid   <- predGrid[wk,]
  }
  list(gridBySpec = gridBySpec, predGrid = predGrid)
}

.spec2Trait <- function(pbys, sbyt, tTypes){
  
  # plotBySpec  - n by S numeric matrix
  # specByTrait - S by M data.frame
  # traitTypes  - data types for traits
  # FC can be factors that will be categorical
  
  n <- nrow(pbys)
  S <- ncol(pbys)
  M <- ncol(sbyt)
  
  ttt <- numeric(0)
  
  y2t  <- match(colnames(pbys),rownames(sbyt))  
  y2tf <- which(is.finite(y2t))
  t2y  <- match(rownames(sbyt),colnames(pbys))
  t2yf <- which(is.finite(t2y))
  
  if(is.data.frame(pbys))pbys <- as.matrix(pbys)
  
  ywt <- sweep(pbys,1,rowSums(pbys,na.rm=T),'/')
  ywt[is.na(ywt)] <- 0
  
  newTypes <- character(0)
  tmat     <- ttt <- numeric(0)
  
  ###################### neither ordinal nor factors (FC)
  
  wf   <- which( !tTypes %in% c('OC','CAT') ) 

  if(length(wf) > 0){
    newTypes <- tTypes[wf]
    ttt <- sbyt[ y2t, wf, drop=F]
    tmat <- ywt%*%as.matrix( sbyt[y2t, wf, drop=F] )
  }
  
  ###################### ordinal classes
  
  ordNames <- which(tTypes == 'OC')
  
  if(length(ordNames) > 0){
    ordTraits <- as.matrix( round(sbyt[y2t[y2tf],ordNames],0) )
    ordCols   <- .ordTraitsFromWts(ywt,ordTraits)
    if(is.null(colnames(ordCols)))colnames(ordCols) <- colnames(ordTraits) <- 
      colnames(sbyt)[ordNames]
    ttt <- cbind(ttt, ordTraits )
    tmat <- cbind(tmat,ordCols)
    newTypes <- c(newTypes,tTypes[ordNames])
  }
  
  ##################### CAT to FC
  
  censor <- NULL
  mcol   <- ncol(tmat)
  if(is.null(mcol))mcol <- 0
  xx     <- numeric(0)
  FCgroups <- rep(0,mcol)   
  
  wf <- numeric(0)
  for(j in 1:ncol(sbyt))if(is.factor(sbyt[,j]))wf <- c(wf,j)
  
  wf <- union(wf,which(tTypes %in% 'CAT'))
  
  if(length(wf) > 0){
    
    xx <- sbyt[,wf,drop=F] 
    xc <- numeric(0)
    kg <- 0
    
    for(kk in 1:length(wf)){
      
      xkk  <- xx[,kk]            # rare type is reference
      xtab <- table(xkk)
      if(length(xtab) == 1){
        stop( paste('CAT trait _',names(xx)[kk],
                    '_ has only 1 level, need at least 2',sep='') )
      }
        
      xtab <- xtab[order(xtab)]
      xkk  <- relevel(xkk,ref=names(xtab)[1])
      cont <- contrasts(xkk,contrasts = F)
      xk   <- cont[xkk,,drop=F]
      tmp  <- ywt[,t2y]%*%xk[t2y,]
      
      if(ncol(tmp) == 2){
        mc    <- mcol + 1
        ktype <- 'CA'
        tmp <- tmp[,1,drop=F]
        gk  <- 0
        tc <- gjamCensorY( values = c(0,1), 
                           intervals = cbind( c(-Inf,0), c(1,Inf) ),
                           y = tmp)
        ttt <- cbind(ttt,xk[,1,drop=F])
        
        if(is.null(censor)){
          censor <- c(censor, tc$censor)
          censor$CA$columns <- mc
        } else {
          censor$CA$columns <- c(censor$CA$columns,mc)
        }
        
      } else {
        
        mc    <- ncol(tmp)
        cname <- colnames(tmp)
        cname[1] <- 'other'
        cname <- paste(colnames(xx)[kk],cname,sep='')
        colnames(tmp) <- colnames(xk) <- cname
        
        ttt   <- cbind(ttt,xk)
        ktype <- rep('FC',ncol(tmp))
        
        kg    <- kg + 1
        gk    <- rep(kg,mc)
      }
      
      mcol <- mcol + ncol(tmp)
      
      FCgroups <- c(FCgroups,gk)
      xc   <- cbind(xc,tmp)
      newTypes <- c(newTypes,ktype)

    }
    tmat <- cbind(tmat,xc)
  }
  
  colnames(tmat) <- colnames(ttt)
  
  attr(newTypes,'FCgroups') <- FCgroups

  list(plotByCWM = tmat, traitTypes = newTypes, censor = censor,
       specByTrait = ttt)
}
                
.boxplotQuant <- function( xx, ..., boxfill=NULL ){
  
  pars <- list(...)
  tmp <- boxplot( xx, ..., plot=F)
  if(!'stats' %in% names(pars)){
    ss  <- apply( xx, 2, quantile, pnorm(c(-1.96,-1,0,1,1.96)) ) 
    tmp$stats <- ss
  }else{
    tmp$stats <- pars$stats
  }
  
 if( 'col' %in% names(pars) )boxfill <- pars$col
  
  bxp( tmp, ..., boxfill = boxfill )
  
  tmp
}

.gjamOrd <- function( output, SPECLABS, col, cex, PLOT, method ){
  
  # method can be 'PCA' or 'NMDS'
  
  ematrix   <- output$parameters$ematrix
  ematAlpha <- output$modelList$ematAlpha
  
  y <- output$inputs$y
  S <- SO <- ncol(y)
  snames  <- colnames(y)
  
  if(is.null(col))col <- rep('black',S)
  
  other <- output$inputs$other
  notOther <- output$inputs$notOther
  
  SO <- length(notOther)

  plab <- c('Axis I', 'Axis II', 'Axis III')
  
  if (method == 'NMDS') {
    tmp    <- isoMDS(.cov2Dist(ematrix[notOther,notOther]), k = 3)
    eVecs  <- tmp$points
    colnames(eVecs) <- paste('NMDS',c(1:3),sep = '_')
    eValues <- lambda <- cl <- NULL
  } else {
    tmp <- eigen(ematrix[notOther,notOther])    # PCA
    eVecs   <- tmp$vectors
    eValues <- tmp$values
    lambda  <- eValues/sum(eValues)
    cl      <- cumsum(lambda)
    clab    <- paste(' (',round(100*lambda,0),'%)',sep='')
    plab    <- paste(plab, clab, sep='')
  }
  rownames(eVecs) <- snames[notOther]
  
  if(!PLOT) return( list(eVecs = eVecs, eValues = eValues) )
  
  cbord <- .getColor(col[notOther],.6)
  
  par(mfcol=c(2,2), bty='n', cex = cex, mar=c(4,4,1,1))
  
  plot(eVecs[,1],eVecs[,2],cex=1,col=cbord, bg = cbord, pch=16,
       xlab=plab[1], ylab = plab[2]) 
  abline(h=0,col=.getColor('black',.3),lwd=2,lty=2)
  abline(v=0,col=.getColor('black',.3),lwd=2,lty=2)
  
  if(length(SPECLABS) > 0){
    mmm <- match(SPECLABS,rownames(eVecs))
    text(eVecs[mmm,2],eVecs[mmm,3],SPECLABS,col=cbord[notOther][mmm])
  }
  
  plot(eVecs[,1],eVecs[,3],cex=1,col=cbord, bg = cbord, pch=16,
       xlab=plab[1], ylab = plab[3]) 
  abline(h=0,col=.getColor('black',.3),lwd=2,lty=2)
  abline(v=0,col=.getColor('black',.3),lwd=2,lty=2)
  
  if(length(SPECLABS) > 0){
    mmm <- match(SPECLABS,rownames(eVecs))
    text(eVecs[mmm,2],eVecs[mmm,3],SPECLABS,col=cbord[notOther][mmm])
  }
  
  plot(eVecs[,2],eVecs[,3],cex=1,col=cbord, bg = cbord, pch=16,
       xlab=plab[2], ylab = plab[3])
  abline(h=0,col=.getColor('black',.3),lwd=2,lty=2)
  abline(v=0,col=.getColor('black',.3),lwd=2,lty=2)
  
  if(length(SPECLABS) > 0){
    mmm <- match(SPECLABS,rownames(eVecs))
    text(eVecs[mmm,2],eVecs[mmm,3],SPECLABS,col=cbord[notOther][mmm])
  }
  
  if(method == 'PCA'){
    plot(cl,type='s',xlab='Rank',ylab='Proportion of variance',xlim=c(.9,S),
         ylim=c(0,1),log='x',lwd=2)
    lines(c(.9,1),c(0,cl[1]),lwd=2,type='s')
    for(j in 1:length(lambda))lines(c(j,j),c(0,cl[j]),col='grey')
    lines(cl,lwd=2,type='s')
    abline(h=1,lwd=2,col=.getColor('grey',.5),lty=2)
  }
  
  list(eVecs = eVecs, eValues = eValues)
} 


columnSplit <- function(vec, sep='_', ASFACTOR = F, ASNUMERIC=F,
                        LASTONLY=F){
  
  vec <- as.character(vec)
  nc  <- length( strsplit(vec[1], sep)[[1]] )
  mat <- matrix( unlist( strsplit(vec, sep) ), ncol=nc, byrow=T )
  if(LASTONLY & ncol(mat) > 2){
    rnn <- mat[,1]
    for(k in 2:(ncol(mat)-1)){
      rnn <- columnPaste(rnn,mat[,k])
    }
    mat <- cbind(rnn,mat[,ncol(mat)])
  }
  if(ASNUMERIC){
    mat <- matrix( as.numeric(mat), ncol=nc )
  }
  if(ASFACTOR){
    mat <- data.frame(mat)
  }
  mat
}


columnPaste <- function(c1, c2, sep='-', NOSPACE = FALSE){
  
  c1    <- as.character(c1)
  c2    <- as.character(c2)
  if(NOSPACE){
    c1   <- .replaceString(c1, ' ', '')
    c2   <- .replaceString(c2, ' ', '')
  }
  c12   <- apply( cbind(c1, c2) , 1, paste0, collapse=sep)
  
  c12
}