Nothing
# This file is part of the RcmdrPlugin.Export package.
# The current code is based on code taken from Rcmdr.
# file created: 02 Feb 2008
# last modified: 07 Oct 2008
xtableExport <- function(){
.tmpObject <- popOutput(keep=TRUE)
objectClass <- class(.tmpObject)
objectClass <- objectClass[[1]]
if (is.null(objectClass) == "TRUE" | objectClass == "logical"){
.tmpObject <- popOutput()
rm(.tmpObject)
Message(message=paste("xtable() cannot export objects of class '", objectClass,
"'", sep=""), type="note")
Message(message=paste("the stack is probably empty", sep=""), type="warning")
return()
}
else if (objectClass == "function" | objectClass == "help_files_with_topic" |
objectClass == "packageIQR" | objectClass == "trellis" | objectClass == "xtable" |
objectClass == "latex" | objectClass == "htest" | objectClass == "stem.leaf" |
objectClass == "multinom" | objectClass == "try-error"){
.tmpObject <- popOutput()
rm(.tmpObject)
Message(message=paste("xtable() cannot export objects of class '", objectClass,
"'", sep=""), type="note")
return(xtableExport())
}
else {
initializeDialog(title=gettextRcmdr("Export objects using xtable()"))
}
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, paste(objectClass), title=gettextRcmdr("Object class"))
radioButtons(window=dataFrame, name="type", buttons=c("latex", "html"),
values=c("LaTeX", "HTML"), labels=gettextRcmdr(c("LaTeX", "HTML")),
title=gettextRcmdr("Export format"))
optionsFrame <- tkframe(top)
captionInput <- tclVar("")
captionField <- tkentry(optionsFrame, width="15", textvariable=captionInput)
radioButtons(window=optionsFrame, name="caption.place",
buttons=c("top", "bottom"),
values=c("top", "bottom"), initialValue="bottom",
labels=gettextRcmdr(c("Top", "Bottom")),
title=gettextRcmdr("Caption place."))
labelInput <- tclVar("")
labelField <- tkentry(optionsFrame, width="15", textvariable=labelInput)
alignInput <- tclVar("")
alignField <- tkentry(optionsFrame, width="15", textvariable=alignInput)
if (objectClass == "numSummary") {
objectCol <- ncol(.tmpObject$table)
} else if (objectClass == "summary.lm") {
objectCol <- ncol(.tmpObject$coefficients)
} else if (objectClass == "rcorr"){
objectCol <- ncol(.tmpObject$r)
} else if (objectClass == "rcorr.adjust"){
objectCol <- ncol(.tmpObject$R$r)
} else if (objectClass == "confint.glht"){
objectCol <- ncol(.tmpObject$confint)
} else if (objectClass == "factanal"){
objectCol <- ncol(.tmpObject$loadings)
} else if (objectClass == "reliability"){
objectCol <- ncol(.tmpObject$rel.matrix)
} else if (objectClass == "summary.aov" & length(.tmpObject)==1) {
objectCol <- ncol(.tmpObject[[1]])
} else if (objectClass == "summary.princomp") {
objectCol <- length(.tmpObject$sdev)
} else {
objectCol <- ncol(.tmpObject)
}
if (is.null(objectCol)) {
digitsVector <- paste("2")
}
else if (is.na(objectCol)) {
digitsVector <- paste("2")
}
else digitsVector <- paste("c(", paste(rep("2,", objectCol), collapse=""), "2)", sep="")
digitsInput <- tclVar(paste(digitsVector))
digitsField <- tkentry(optionsFrame, width="15", textvariable=digitsInput)
displayInput <- tclVar("")
displayField <- tkentry(optionsFrame, width="15", textvariable=displayInput)
additionalFrame <- tkframe(top)
sizeInput <- tclVar("normal")
sizeField <- tkentry(additionalFrame, width="15", textvariable=sizeInput)
naInput <- tclVar("")
naField <- tkentry(additionalFrame, width="15", textvariable=naInput)
fileInput <- tclVar("")
fileField <- tkentry(additionalFrame, width="15", textvariable=fileInput)
appendVariable <- tclVar("1")
appendCheckBox <- tkcheckbutton(additionalFrame, variable=appendVariable)
floatVariable <- tclVar("1")
floatCheckBox <- tkcheckbutton(additionalFrame, variable=floatVariable)
radioButtons(window=additionalFrame, name="tab.env",
buttons=c("tabular", "longtable"),
values=c("tabular", "longtable"), #initialValue="tabular",
labels=gettextRcmdr(c("tabular", "longtable")),
title=gettextRcmdr("Tabular env."))
onOK <- function(){
type <- tclvalue(typeVariable)
caption <- paste(tclvalue(captionInput))
caption.place <- tclvalue(caption.placeVariable)
label <- paste(tclvalue(labelInput))
align <- paste(tclvalue(alignInput))
digits <- paste(tclvalue(digitsInput))
if (digits == "2"){
digits <- paste("")
}
else if (digits == digitsVector){
digits <- paste("")
}
display <- paste(tclvalue(displayInput))
size <- paste(tclvalue(sizeInput))
na <- paste(tclvalue(naInput))
file <- paste(tclvalue(fileInput))
append <- paste(tclvalue(appendVariable))
float <- paste(tclvalue(floatVariable))
tab.env <- tclvalue(tab.envVariable)
closeDialog()
if (caption != ""){
caption <- paste(", caption=", '"', paste(tclvalue(captionInput)), '"', sep="")
if (caption.place == "top"){
caption.place <- paste(", caption.placement=", '"', paste(tclvalue(caption.placeVariable)), '"', sep="")
} else
caption.place <- paste("", sep="")
} else
caption.place <- paste("", sep="")
if (label != ""){
label <- paste(", label=", '"', paste(tclvalue(labelInput)), '"', sep="")
}
if (align != ""){
align <- paste(", align=", '"', paste(tclvalue(alignInput)), '"', sep="")
}
if (digits != ""){
digits <- paste(", digits=", paste(tclvalue(digitsInput)), sep="")
}
if (display != ""){
display <- paste(", display=", '"', paste(tclvalue(displayInput)), '"', sep="")
}
if (size != ""){
if (size == "normal"){
size <- paste("", sep="")
}
else size <- paste(", size=", '"', paste(tclvalue(sizeInput)), '"', sep="")
}
if (na != ""){
na <- paste(", NA.string=", '"', paste(tclvalue(naInput)), '"', sep="")
}
if (file != ""){
if (type == "LaTeX"){
file <- paste(", file=", '"', paste(tclvalue(fileInput)), '.tex"', sep="")
}
else if (type == "HTML"){
file <- paste(", file=", '"', paste(tclvalue(fileInput)), '.html"', sep="")
}
if (append == "1"){
append <- paste(", append=TRUE", sep="")
}
else if (append == "0"){
append <- paste("", sep="")
}
}
else if (file == ""){
append <- paste("", sep="")
}
if (float == "1"){
float <- paste("", sep="")
} else
if (float == "0"){
float <- paste(", floating=FALSE", sep="")
}
if (tab.env == "longtable"){
tab.env <- paste(", tabular.environment=", '"', paste(tclvalue(tab.envVariable)), '"', sep="")
} else
tab.env <- paste("", sep="")
objectCommandName <- NULL
commandRepeat <- 1
objectName <- paste(".", objectClass, sep="")
if (objectClass == "numSummary"){
objectCommandName <- paste("as.table(", objectName, "$table)", sep="")
} else if (objectClass == "summary.multinom"){
objectCommandName[1] <- paste("as.data.frame(", objectName, "$coefficients)", sep="")
objectCommandName[2] <- paste("as.data.frame(", objectName, "$standard.errors)", sep="")
commandRepeat <- 2
} else if (objectClass == "polr"){
objectCommandName[1] <- paste("as.data.frame(", objectName, "$coefficients)", sep="")
objectCommandName[2] <- paste("as.data.frame(", objectName, "$zeta)", sep="")
commandRepeat <- 2
} else if (objectClass == "summary.polr"){
objectCommandName <- paste(objectName, "$coefficients", sep="")
} else if (objectClass == "reliability"){
objectCommandName <- paste(objectName, "$rel.matrix", sep="")
} else if (objectClass == "confint.glht"){
objectCommandName <- paste(objectName, "$", "confint", sep="")
} else if (objectClass == "factanal"){
objectCommandName <- paste("as.table(", objectName, "$loadings)", sep="")
} else if (objectClass == "outlier.test"){
objectCommandName <- paste("as.matrix(", objectName, "$test)", sep="")
} else if (objectClass == "array" | objectClass == "integer" |
objectClass == "character" | objectClass == "numeric"){
objectCommandName <- paste("as.data.frame(", objectName, ")", sep="")
} else if (objectClass == "rcorr"){
commandRepeat <- 3
objectCommandList <- c("$r", "$n", "$P")
for (i in 1:commandRepeat){
objectCommandName[i] <- paste(objectName, objectCommandList[i], sep="")
}
} else if (objectClass == "rcorr.adjust"){
commandRepeat <- 4
objectCommandList <- c("$R$r", "$R$n", "$R$P", "$P")
for (i in 1:commandRepeat){
objectCommandName[i] <- paste(objectName, objectCommandList[i], sep="")
}
} else if (objectClass == "by" & is.list(.tmpObject)==TRUE){
commandRepeat <- length(.tmpObject)
for (i in 1:commandRepeat){
objectCommandName[i] <- paste("as.matrix(", objectName,
"[[", i, "]])", sep="")
}
} else if (objectClass == "summary.princomp"){
objectCommandName <- paste("as.matrix(", objectName, "$sdev)", sep="")
} else {
objectName <- paste(".object", sep="")
objectCommandName <- paste(objectName)
}
assign(objectName, .tmpObject)
cmds <- character(1)
cmds[1] <- paste0("local({\n ",
"## retrieve the last printed object\n ",
objectName, " <- popOutput()")
# justDoIt(paste(objectName, " <- .tmpObject", sep=""))
# logger(paste(objectName, " <- popOutput() ## retrieve the last printed object", sep=""))
##always use print for length(commandRepeat)>1
if(type == "LaTeX"){
if(size!="" | na!="" | file!="" | caption.place!="" |
float!="" | tab.env!="" | commandRepeat>1){
usePrint <- paste("print(", sep="")
printType <- paste(", type=", '"', "latex", '"', ")", sep="")
} else {
usePrint <- paste("", sep="")
printType <- paste("", sep="")
}
}
else if (type == "HTML"){
usePrint <- paste("print(", sep="")
printType <- paste(", type=", '"', "html", '"', ")", sep="")
}
run.command <- character(commandRepeat)
for (i in 1:commandRepeat){
run.command[i] <- paste0(" ", usePrint, "xtable(", objectCommandName[i],
caption, label, align, digits, display, ")", caption.place,
size, na, file, append, float, tab.env, printType)
}
commands <- paste(c(cmds[1], run.command), collapse="\n")
doItAndPrint(paste(commands, "\n})", sep=""))
# justDoIt(paste('rm(list=c(".tmpObject", "', objectName, '"))', sep=""))
# logger(paste("remove(", objectName, ")", sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="xtable")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(typeFrame, sticky="sw")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Arguments"), fg="blue"))
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Caption:")), captionField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Label:")), labelField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Align:")), alignField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Digits:")), digitsField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Display:")), displayField, sticky="w")
tkgrid(tklabel(optionsFrame, text=gettextRcmdr(" ")), sticky="w")
tkgrid(caption.placeFrame, sticky="sw")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("Printing"), fg="blue"))
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("Size:")), sizeField, sticky="w")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("NA string:")), naField, sticky="w")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("File:")), fileField, sticky="w")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("Append")), appendCheckBox, sticky="w")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr("Floating")), floatCheckBox, sticky="w")
tkgrid(tklabel(additionalFrame, text=gettextRcmdr(" ")), sticky="w")
tkgrid(tab.envFrame, sticky="sw")
tkgrid(dataFrame, tklabel(top, text=" "), optionsFrame, tklabel(top, text=" "),
additionalFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=3)
}
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.