print.xtable.bpca <- function(x,
hline.after=getOption("xtable.hline.after", NULL),
include.colnames=getOption("xtable.include.colnames", FALSE),
add.to.row=getOption("xtable.add.to.row", NULL),
sanitize.text.function=getOption("xtable.sanitize.text.function", NULL),
sanitize.rownames.function=getOption("xtable.sanitize.rownames.function", sanitize.text.function),
sanitize.colnames.function=getOption("xtable.sanitize.rownames.function", sanitize.text.function), ...)
{
aux_attr <- attr(x,'align')
attr(x,'align') <- c('l', aux_attr)
if(is.null(sanitize.rownames.function)){
morerow <- function(x) paste("&",
x,
collpase='')
sanitizerownamesfunction <- morerow
}else{
morerow <- function(x) paste("&",
sanitize.rownames.function(x),
collpase='')
sanitizerownamesfunction <- morerow
}
if(is.null(sanitize.colnames.function)){
sanitize.colnames.function <- function(x) x
}
if(is.null(add.to.row)){
variables <- rownames(x)[1:(length(rownames(x))-3)]
nvariables <- length(variables)
components <- dimnames(x)[[2]]
ncomponents <- length(components)
whatcomponents <- as.numeric(gsub("[A-Za-z]*","",components))
label_eigenvec <- unique(gsub("(\\\\_[\\s\\S]*)",
"",
variables,
perl=TRUE))
label_eigenval <- rownames(x)[length(rownames(x))-2]
label_variance <- rownames(x)[-(1:(nvariables+1))]
newvariables <- gsub(paste(label_eigenvec,
"\\\\_",
sep=""),
"",
variables)
head1 <- paste("&&\\multicolumn{",
ncomponents,
"}{c}{",
sanitize.colnames.function(label_eigenval),
"} \\\\ \\cline{3-",
length(aux_attr)+1,
"}\n",
sep="")
aux_head21 <- c("&& ",
rep("",
ncomponents-1))
aux_head22 <- paste(components,
" $(\\lambda_",
whatcomponents,
"=",
round(as.numeric(x[nvariables+1,]),
attr(x,
'digits')[2]),
")$",
sep='')
aux_head23 <- paste(aux_head21,
sanitize.colnames.function(aux_head22),
collapse='&')
head2 <- paste(aux_head23,
"\\\\ \n ",
collapse="")
# A função sanitize.rownames.function deve ser aplicada ao objeto newvariables também!
# aux_com1 <- paste(paste("\\hline \n \\multirow{",
# nvariables,
# "}{*}{",
# sanitize.rownames.function(label_eigenvec),
# "}",
# sep=''),
# newvariables[1],
# sep='&')
label_eigenvec <- ifelse(is.null(sanitize.rownames.function),
label_eigenvec,
label_eigenvec <- sanitize.rownames.function(label_eigenvec))
firstvariablerow <-ifelse(is.null(sanitize.rownames.function),
newvariables[1],
firstvariablerow <- sanitize.rownames.function(newvariables[1]))
aux_com1 <- paste(paste("\\hline \n \\multirow{",
nvariables,
"}{*}{",
label_eigenvec,
"}",
sep=''),
firstvariablerow,
sep='&')
aux_com11 <- gsub("(&\\s)",
"",
aux_com1,
perl=TRUE)
aux_com2 <- paste(round(x[1,],
attr(x,
'digits')[2]),
collapse='&')
if(include.colnames){
add.to.row <- list(pos=list(0, 0, 0, 0),
command=NULL)
aux_head01 <- paste("&",
colnames(x))
aux_head02 <- paste(aux_head01,
collapse="")
head0 <- paste("&",
aux_head02,
"\\\\ \n")
command <- c(head0,
head1,
head2,
paste(paste(aux_com11,
aux_com2,
sep='&'),
'\\\\ \n'))
} else {
add.to.row <- list(pos=list(0, 0, 0),
command=NULL)
command <- c(head1,
head2,
paste(paste(aux_com11,
aux_com2,
sep='&'),
'\\\\ \n'))
}
add.to.row$command <- command
}
rownames(x) <- c(newvariables,
label_eigenval,
label_variance)
if(is.null(hline.after)){
hline.after <- c(-1,
nrow(x[-c(1,nvariables+1),])-2,
nrow(x[-c(1,nvariables+1),]))
}
print.xtable(x[-c(1,nvariables+1),],
hline.after=hline.after,
include.colnames=FALSE,
sanitize.rownames.function=sanitizerownamesfunction,
add.to.row=add.to.row,
...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.