`report.mefa` <-
function (x, filename, segment = FALSE, n = NULL, by.taxa = TRUE,
samp.var = NULL, drop.redundant = NULL, collapse = TRUE,
taxa.name = NULL, author.name = NULL, taxa.order = NULL,
grouping = FALSE, tex = FALSE, binary = FALSE,
tex.control = list(ital.taxa = TRUE, noindent = TRUE,
bold.sect = TRUE, bold.1st = TRUE, vspace1 = 0.5, vspace2 = 0.2),
sep = c(",", ":", "(", ":", ",", ")", ";"), dir = getwd(), ...)
{
current.dir <- getwd()
setwd(dir)
on.exit(setwd(current.dir))
mf <- x[drop = TRUE]
if (is.null(taxa.name)) {
taxa.name <- 1
mf$taxa <- data.frame(rownames(mf$taxa), mf$taxa)}
# test
if(!is.mefa(mf))
stop("object is not of class 'mefa'")
if (is.null(mf$samp) || is.null(mf$taxa))
stop("report needs both '$samp' and '$taxa'")
if (length(sep) != 7)
stop("specify exactly 7 'sep' values")
if (is.null(taxa.order))
taxa.order <- taxa.name
if (is.character(n))
n <- which(names(mf$segm) %in% n)
length.n <- 1
if (!is.null(n) && is.null(mf$segm))
stop("no segments found")
if (segment && is.null(mf$segm))
stop("no segments found")
if (segment && is.null(n))
length.n <- dim(mf)[3]
if (segment && !is.null(n))
length.n <- length(n)
# ordering sample attributes
if (is.null(samp.var))
loca <- mf$samp else loca <- mf$samp[, samp.var]
nnloca <- loca
names(nnloca) <- NULL
ord_loca <- do.call(order, nnloca)
loc <- loca[ord_loca, ]
if (!is.null(drop.redundant) & length(drop.redundant) >= ncol(loca))
stop("'drop.redundant' should be smaller than length of 'samp.var'")
# total count data
if (!segment) {
mfdata <- mf$xtab
mfd <- list(mf$xtab)
}
if (segment) {
if (is.null(n)) {
mfdata <- mf$xtab
mfd <- list()
for (i in 1:dim(mf)[3]) {
runname <- paste(dimnames(mf)$segm[i])
mfd[[runname]] <- mf$segm[[i]]
}
}
if (!is.null(n)) {
if (length(n) == 1) mfdata <- mf$segm[[n]]
if (length(n) > 1) {
mfdata <- mf$segm[[n[1]]]
for (i in 2:length(n)) mfdata <- mfdata + mf$segm[[n[i]]]
}
mfd <- list()
for (i in 1:length(n)) {
runname <- paste(dimnames(mf)$segm[n[i]])
mfd[[runname]] <- mf$segm[[n[i]]]
}
}
}
# ordering counts
xcr <- mfdata[ord_loca, order(mf$taxa[, taxa.order])]
mfdl <- list()
for (i in 1:length.n) {
mfdl[[i]] <- mfd[[i]][ord_loca, order(mf$taxa[, taxa.order])]
}
names(mfdl) <- names(mfd)
# species names
nam <- as.vector(mf$taxa)[, taxa.name][order(mf$taxa[, taxa.order])]
if (!is.null(author.name))
autv <- as.vector(mf$taxa)[, author.name][order(mf$taxa[, taxa.order])]
# formatting
if (tex & tex.control$ital.taxa) ti <- "\\textit{" else ti <- ""
if (tex & tex.control$bold.1st) tb <- "\\textbf{" else tb <- ""
if (tex & tex.control$bold.sect) tb2 <- "\\textbf{" else tb2 <- ""
if (tex) noin <- "\\noindent " else noin <- ""
if (tex & tex.control$noindent) noin1 <- "\\noindent " else noin1 <- ""
if (tex & grouping & tex.control$noindent) noin2 <- "\\noindent " else noin2 <- ""
if (tex & tex.control$ital.taxa) clbr <- "}" else clbr <- ""
if (tex & tex.control$bold.1st) clbr2 <- "}" else clbr2 <- ""
if (tex & tex.control$bold.sect) clbr3 <- "}" else clbr3 <- ""
vspace1 <- tex.control$vspace1
vspace2 <- tex.control$vspace2
calling <- deparse(match.call())
calling <- gsub(" ", "", calling)
# START ordering=species
if (by.taxa) {
zz <- file(filename, "w")
cat("%% Start writing data from a 'mefa' object sorted by species into file \"",
filename, "\" on ", date(), ".\n%% Call: ", calling, "\n", file = zz, sep = "")
# start of SPEC loop
for (spec in 1:length(nam)) {
# start of IF >0
if (sum(xcr[, spec]) > 0) {
# specname cat
if (is.null(author.name)) {
spprint <- paste(noin,tb2,ti,nam[spec],clbr,clbr3,"\n\n",sep="")
} else{
spprint <- paste(noin,tb2,ti,nam[spec],clbr," ",autv[spec],clbr3,"\n\n",sep="")
}
cat("\n\n", file = zz, sep = "")
if (tex) cat(paste("\\vspace{",vspace1,"cm} ",sep=""), file = zz, sep = "")
cat(spprint, file = zz, sep = "")
if (tex & !grouping) cat(paste("\\vspace{",vspace2,"cm} ",sep=""), file = zz, sep = "")
# nonzero count subsets
loc.sub <- as.matrix(subset(loc, xcr[, spec] > 0))
lev.sub <- as.factor(loc.sub[,1])
xcr.sub <- subset(xcr[, spec], xcr[, spec] > 0)
mfdl.sub <- matrix(NA,length(xcr.sub),length.n)
colnames(mfdl.sub) <- names(mfdl)
for (i in 1:length.n) {
mfdl.sub[,i] <- as.vector(subset(mfdl[[i]][, spec], xcr[, spec] > 0))
}
# collapse - exclude and aggregate
leave <- rep(1,nrow(loc.sub))
aggr <- c(1:nrow(loc.sub))
if (collapse) {
for (i in 1:nrow(loc.sub)){
if (i > 1) if (sum(loc.sub[i,] == loc.sub[(i-1),]) == ncol(loc.sub)) leave[i] <- 0
aggr[i] <- paste(loc.sub[i,],collapse="")
}
aggr <- as.numeric(as.factor(aggr))
loc.sub <- subset(loc.sub, leave==1)
lev.sub <- subset(lev.sub, leave==1)
xcr.sub <- aggregate(xcr.sub,list(aggr),sum)[,2]
mfdl.sub <- aggregate(mfdl.sub,list(aggr),sum)[,-1]
}
if (!is.null(drop.redundant)) {
kloc.sub <- as.matrix(loc.sub)
if (nrow(kloc.sub) > 1) {
for (col in 1:drop.redundant) {
for (row in 1:(nrow(loc.sub)-1)) {
if (loc.sub[row, col] == loc.sub[(row+1), col]) kloc.sub[(row+1), col] <- ""
}
}
if (drop.redundant > 1) {
for (col in 2:drop.redundant) {
for (row in 1:nrow(loc.sub)) {
if (kloc.sub[row, (col-1)] != "") kloc.sub[row, col] <- loc.sub[row, col]
}
}}
for (col in 1:drop.redundant) {
for (row in 1:(nrow(loc.sub)-1)) {
if (kloc.sub[row, col] != "" & kloc.sub[(row+1), col] == "")
kloc.sub[row, col] <- paste(sep[2],sep[2],kloc.sub[row, col],sep[2]," ",sep="")
}
}
} # end IF nrow > 1
} else kloc.sub <- loc.sub
for (j in 1:ncol(kloc.sub)) {
for (i in 1:nrow(kloc.sub)) {
test.1st <- substr(kloc.sub[i,j],1,2) == paste(sep[2],sep[2],sep="")
if (kloc.sub[i,j] != "" & !test.1st & j!=ncol(kloc.sub))
kloc.sub[i,j] <- paste(kloc.sub[i,j],sep[1]," ",sep="")
if (kloc.sub[i,j] != "" & !test.1st & j==ncol(kloc.sub))
kloc.sub[i,j] <- paste(kloc.sub[i,j]," ",sep="")
if (test.1st) kloc.sub[i,j] <- gsub(paste(sep[2],sep[2],sep=""),"",kloc.sub[i,j])
}
}
if (!grouping) cat(noin1, file = zz, sep = "")
# loop for first column levels (grouping also)
for (lev in 1:nlevels(lev.sub)) {
if (tex & grouping) cat(paste("\\vspace{",vspace2,"cm} ",sep=""), file = zz, sep = "")
xcr.sub2 <- subset(xcr.sub, lev.sub == levels(lev.sub)[lev])
loc.sub2 <- subset(loc.sub, lev.sub == levels(lev.sub)[lev])
kloc.sub2 <- subset(kloc.sub, lev.sub == levels(lev.sub)[lev])
printcount <- rep("",length(lev.sub[lev.sub==levels(lev.sub)[lev]]))
if (segment){
mfdl.sub2 <- subset(mfdl.sub, lev.sub == levels(lev.sub)[lev])
mfdl.sub2[mfdl.sub2==0] <- paste("DELETEME",sep[5],sep="")
for (i in 1:nrow(mfdl.sub2)) {
for (j in 1:ncol(mfdl.sub2)) {
if (mfdl.sub2[i,j] != paste("DELETEME",sep[5],sep=""))
if (binary) {
mfdl.sub2[i,j] <- paste(colnames(mfdl.sub2)[j],sep="")
} else {
mfdl.sub2[i,j] <- paste(colnames(mfdl.sub2)[j],sep[4]," ",mfdl.sub2[i,j],sep="")}
}
printcount[i] <- paste(mfdl.sub2[i,],collapse=paste(sep[5]," ",sep=""))
printcount[i] <- gsub(paste("DELETEME",sep[5],sep[5]," ",sep=""),"", printcount[i])
printcount[i] <- gsub(paste("DELETEME",sep[5],sep=""),"", printcount[i])
}
}
if (!segment) {
for (i in 1:length(printcount))
if (binary) {
printcount[i] <- paste("",sep="")
} else {
printcount[i] <- paste(xcr.sub2[i],sep="")}
}
if (binary & !segment) {
brace1 <- rep("",length(lev.sub[lev.sub==levels(lev.sub)[lev]]))
brace2 <- rep("",length(lev.sub[lev.sub==levels(lev.sub)[lev]]))
} else {
brace1 <- rep(sep[3],length(lev.sub[lev.sub==levels(lev.sub)[lev]]))
brace2 <- rep(sep[6],length(lev.sub[lev.sub==levels(lev.sub)[lev]]))
}
ending <- c(rep(paste(sep[7]," ",sep=""),length(lev.sub[lev.sub==levels(lev.sub)[lev]])-1),". ")
printout0 <- data.frame(kloc.sub2, brace1, printcount, brace2, ending)
colnames(printout0) <- letters[1:ncol(printout0)]
printout <- as.matrix(printout0)
paragraph <- ""
for (i in 1:nrow(printout)) {
for (j in 1:ncol(printout)) {
if (i==1 & j==1) printout[i,j] <- paste(noin2,tb,as.character(printout[i,j]),clbr2,sep="")
else printout[i,j] <- paste(as.character(printout[i,j]),sep="")
paragraph <- paste(paragraph,printout[i,j],sep="")
}}
paragraph <- gsub(" "," ", paragraph)
paragraph <- gsub(paste(sep[5]," ",sep[6],sep=""),paste(sep[6],sep=""), paragraph)
paragraph <- gsub(paste(" ",sep[7]," ",sep=""),paste(sep[7]," ",sep=""), paragraph)
paragraph <- gsub(" . ",". ", paragraph)
paragraph <- gsub(paste(sep[5],". ",sep=""),". ", paragraph)
cat(paragraph, file = zz, sep = "")
if (grouping) cat("\n\n", file = zz, sep = "")
} # end of LEV loop
} # end of IF >0
} # end of SPEC loop
cat("\n\n%% End of output.\n", file = zz, sep = "")
close(zz)
} #END of species ordering
if (!by.taxa) stop("'by.taxa = FALSE' is not yet implemented\n")
invisible()
} # end of function
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.