Nothing
# 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
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.