From 6b257251d2ca5bc6f40d59f0adc53160f799097d Mon Sep 17 00:00:00 2001 From: Philipp Tandler Date: Thu, 8 Aug 2024 15:07:42 -0700 Subject: [PATCH 1/4] adjust matrix initialisation in gjamHfunctions.R and enforced matrix symmetry in cppFns.cpp --- R/gjamHfunctions.R | 29320 +++++++++++++++++++++---------------------- src/cppFns.cpp | 4 +- 2 files changed, 14663 insertions(+), 14661 deletions(-) diff --git a/R/gjamHfunctions.R b/R/gjamHfunctions.R index 508d24b..d68b584 100755 --- a/R/gjamHfunctions.R +++ b/R/gjamHfunctions.R @@ -1,14660 +1,14660 @@ - -# 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 -} + +# 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*S),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 +} diff --git a/src/cppFns.cpp b/src/cppFns.cpp index 059fea1..661cdc5 100755 --- a/src/cppFns.cpp +++ b/src/cppFns.cpp @@ -115,7 +115,9 @@ arma::mat trMVNmatrixRcpp(arma::mat avec, arma::mat muvec, cid(0) = cindex; idx = idxALLm.col(cindex); - sin = arma::inv_sympd(smat.submat(idx, idx)); + arma::mat smatSub = 0.5 * (smat.submat(idx, idx) + trans(smat.submat(idx, idx))); + smatSub = 0.5 * (smatSub + trans(smatSub)); + sin = arma::inv_sympd(smatSub); p1 = trans(smat.submat(idx, cid)) * sin; m1 = mv[cindex] + dot(p1, (av.elem(idx) - mv.elem(idx))); From e9f17a972784a6086dad1b690d82996aa4beb670 Mon Sep 17 00:00:00 2001 From: Philipp Tandler Date: Thu, 8 Aug 2024 15:26:30 -0700 Subject: [PATCH 2/4] Fixed minor bug with correct line endings --- R/gjamHfunctions.R | 29320 +++++++++++++++++++++---------------------- 1 file changed, 14660 insertions(+), 14660 deletions(-) diff --git a/R/gjamHfunctions.R b/R/gjamHfunctions.R index d68b584..8ed14d5 100755 --- a/R/gjamHfunctions.R +++ b/R/gjamHfunctions.R @@ -1,14660 +1,14660 @@ - -# 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*S),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 -} + +# 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*S),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 +} From 727c25924fab73f0e09fb4a43a7f9de6a216fde1 Mon Sep 17 00:00:00 2001 From: Philipp Tandler Date: Thu, 8 Aug 2024 15:38:52 -0700 Subject: [PATCH 3/4] minor bugfix --- R/gjamHfunctions.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/gjamHfunctions.R b/R/gjamHfunctions.R index 8ed14d5..508d24b 100755 --- a/R/gjamHfunctions.R +++ b/R/gjamHfunctions.R @@ -420,7 +420,7 @@ gjamConditionalParameters <- function( output, conditionOn, nsim = 2000 ){ gindex <- gindex[lkeep,] wg <- which(gindex == 1,arr.ind=T) - wc <- matrix(rep(1:M,S*S),S*M,S)[lkeep,] + 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], From 8086ad844e88f06cda3e6504b456374b7e491b19 Mon Sep 17 00:00:00 2001 From: Philipp Tandler Date: Thu, 8 Aug 2024 15:42:30 -0700 Subject: [PATCH 4/4] adjusted matrix initialisation to avoid warning --- R/gjamHfunctions.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/gjamHfunctions.R b/R/gjamHfunctions.R index 508d24b..8ed14d5 100755 --- a/R/gjamHfunctions.R +++ b/R/gjamHfunctions.R @@ -420,7 +420,7 @@ gjamConditionalParameters <- function( output, conditionOn, nsim = 2000 ){ gindex <- gindex[lkeep,] wg <- which(gindex == 1,arr.ind=T) - wc <- matrix(rep(1:M,S*M),S*M,S)[lkeep,] + wc <- matrix(rep(1:M,S*S),S*M,S)[lkeep,] rowG <- wc[wg] gindex <- cbind(rowG,wg) tmp <- as.vector( t(outer(colnames(rho)[notOther],