I improved the code from the last post. This now also works with with systemfit objects with multiple regressions.
#adjusted to allow regression results from the systemfit package to be printed
#use as mytexreg(systemfitobject , ...) the syntax is identical to texreg
#author: johannes.kutsam@gmail.com july 29th, 2012
#license: public domain
library(texreg)
mytexreg=texreg # make a copy of the original
body(mytexreg)=body(texreg2) #replace the function body
generic=setClass("generic",
representation(tab="matrix",gof="matrix"),
prototype=list(tab=matrix(0,0,0),gof=matrix(0,0,0)))
systemfit2texreg=function(s){
eqlist=list()
for(eq in s$eq){
sum=summary(eq)
tab=coef(sum)
tab=tab[,-3] # remove t values
r=sum$r.squared
radj=sum$adj.r.squared
n=nobs(s)
gof=matrix(c(r,radj,n),ncol=1)
row.names(gof)=c("R$^2$","Adj. R$^2$","Num. obs.")
mygen=generic(tab=tab,gof=gof)
eqlist[[eq$eqnNo]]=mygen
}
eqlist
}
extract.generic=function(model){
if(!class(model)=="generic"){
stop("Internal error: Incorrect model type! Should be a systemfit object")
}
list(tab=model@tab,gof=model@gof)
}
texreg2=function (l, single.row = FALSE, no.margin = TRUE, leading.zero = TRUE,
table = TRUE, sideways = FALSE, float.pos = "", strong.signif = FALSE,
symbol = "\\cdot", use.packages = TRUE, caption = "Statistical models",
label = "table:coefficients", dcolumn = TRUE, booktabs = TRUE,
scriptsize = FALSE, custom.names = NA, model.names = NA)
{
string <- ""
if (class(l)[1] == "ergm" | class(l)[1] == "lme" | class(l)[1] ==
"lm" | class(l)[1] == "gls" | class(l)[1] == "glm" | class(l)[1]=="generic") {
l <- list(l)
}
else if (class(l) != "list") {
stop("Unknown object was handed over.")
}
models <- NULL
for (i in 1:length(l)) {
if (class(l[[i]])[1] == "ergm") {
model <- extract.ergm(l[[i]])
models <- append(models, list(model))
}
else if (class(l[[i]])[1] == "lme") {
model <- extract.lme(l[[i]])
models <- append(models, list(model))
}
else if (class(l[[i]])[1] == "lm") {
model <- extract.lm(l[[i]])
models <- append(models, list(model))
}
else if (class(l[[i]])[1] == "gls") {
model <- extract.gls(l[[i]])
models <- append(models, list(model))
}
else if (class(l[[i]])[1] == "glm") {
model <- extract.glm(l[[i]])
models <- append(models, list(model))
}
else if (class(l[[i]])[1] == "generic") {
model <- extract.generic(l[[i]])
models <- append(models, list(model))
}
else {
warning(paste("Skipping unknown model of type ",
class(l[[i]]), ".", sep = ""))
}
}
gof.names <- character()
for (i in 1:length(models)) {
for (j in 1:length(models[[i]][[2]])) {
if (!row.names(models[[i]][[2]])[j] %in% gof.names) {
gof.names <- append(gof.names, row.names(models[[i]][[2]])[j])
}
}
}
coefs <- list()
gofs <- matrix(nrow = length(gof.names), ncol = length(models))
row.names(gofs) <- gof.names
for (i in 1:length(models)) {
coefs <- append(coefs, models[[i]][1])
for (j in 1:length(models[[i]][[2]])) {
rn <- row.names(models[[i]][[2]])[j]
val <- models[[i]][[2]][j]
col <- i
row <- which(row.names(gofs) == rn)
gofs[row, col] <- val
}
}
coef.order <- character()
for (i in 1:length(coefs)) {
for (j in 1:length(rownames(coefs[[i]]))) {
if (!rownames(coefs[[i]])[j] %in% coef.order) {
coef.order <- append(coef.order, rownames(coefs[[i]])[j])
}
}
}
if (length(coefs) == 1) {
m <- coefs[[1]]
}
else if (length(coefs) > 1) {
m <- coefs[[1]]
for (i in 2:length(coefs)) {
m <- merge(m, coefs[[i]], by = 0, all = TRUE)
rownames(m) <- m[, 1]
m <- m[, colnames(m) != "Row.names"]
colnames(m) <- NULL
}
}
colnames(m) <- rep(colnames(coefs[[1]]), length(coefs))
m.temp <- matrix(nrow = nrow(m), ncol = ncol(m))
for (i in 1:nrow(m)) {
new.row <- which(coef.order == rownames(m)[i])
for (j in 1:length(m[i, ])) {
m.temp[new.row, j] <- m[i, j]
}
}
rownames(m.temp) <- coef.order
colnames(m.temp) <- colnames(m)
m <- m.temp
if (length(custom.names) > 1) {
if (!class(custom.names) == "character") {
stop("Custom coefficient names must be provided as a vector of strings!")
}
else if (length(custom.names) != length(rownames(m))) {
stop(paste("There are", length(rownames(m)), "coefficients, but you provided",
length(custom.names), "custom names for them."))
}
else {
rownames(m) <- custom.names
}
}
else if (!is.na(custom.names) & class(custom.names) != "character") {
stop("Custom coefficient names must be provided as a vector of strings.")
}
else if (length(custom.names) == 1 & class(custom.names) ==
"character") {
rownames(m) <- custom.names
}
for (i in 1:length(rownames(m))) {
for (j in 1:length(rownames(m))) {
if (i != j & rownames(m)[i] == rownames(m)[j]) {
identical <- logical(length(m[i, ]))
for (k in 1:length(m[i, ])) {
if ((is.na(m[i, k]) & !is.na(m[j, k])) | (!is.na(m[i,
k]) & is.na(m[j, k])) | (is.na(m[i, k]) &
is.na(m[j, k]))) {
identical[k] <- TRUE
}
}
if (length(identical[identical == FALSE]) ==
0) {
for (k in 1:ncol(m)) {
if (is.na(m[i, k])) {
m[i, k] <- m[j, k]
}
else if (is.na(m[j, k])) {
m[j, k] <- m[i, k]
}
}
}
}
}
}
m <- m[duplicated(m) == FALSE, ]
m <- as.data.frame(m)
lab.list <- c(rownames(m), gof.names)
lab.length <- 0
for (i in 1:length(lab.list)) {
if (nchar(lab.list[i]) > lab.length) {
lab.length <- nchar(lab.list[i])
}
}
string <- paste(string, "\n", sep = "")
if (use.packages == TRUE) {
if (sideways == TRUE & table == TRUE) {
string <- paste(string, "\\usepackage{rotating}\n",
sep = "")
}
if (booktabs == TRUE) {
string <- paste(string, "\\usepackage{booktabs}\n",
sep = "")
}
if (dcolumn == TRUE) {
string <- paste(string, "\\usepackage{dcolumn}\n\n",
sep = "")
}
}
if (table == TRUE) {
if (sideways == TRUE) {
t <- "sideways"
}
else {
t <- ""
}
if (float.pos == "") {
string <- paste(string, "\\begin{", t, "table}\n",
sep = "")
}
else {
string <- paste(string, "\\begin{", t, "table}[",
float.pos, "]\n", sep = "")
}
string <- paste(string, "\\begin{center}\n", sep = "")
if (scriptsize == TRUE) {
string <- paste(string, "\\scriptsize\n", sep = "")
}
}
string <- paste(string, "\\begin{tabular}{l ", sep = "")
for (i in 1:length(models)) {
gof.list <- as.vector(gofs[, i])
gof.list.string <- NULL
for (j in 1:length(gof.list)) {
gof.list.string[j] <- coef.to.string(gof.list[j],
leading.zero)
}
if (dcolumn == TRUE) {
dec.left <- max(c(nchar(gof.list.string) - 3), 3)
if (single.row == TRUE) {
dec.right <- 3
separator <- ")"
dec.left <- 11
}
else {
dec.right <- 5
separator <- "."
}
if (no.margin == FALSE) {
margin.arg <- ""
}
else {
margin.arg <- "@{}"
}
string <- paste(string, "D{", separator, "}{", separator,
"}{", dec.left, separator, dec.right, "} ", margin.arg,
sep = "")
}
else {
string <- paste(string, "c ", sep = "")
}
}
if (booktabs == TRUE) {
string <- paste(string, "}\n", "\\toprule\n", sep = "")
}
else {
string <- paste(string, "}\n", "\\hline\n", sep = "")
}
for (k in 1:lab.length) {
string <- paste(string, " ", sep = "")
}
if (length(model.names) > 1) {
if (class(model.names) != "character") {
stop("Model names must be specified as a vector of strings.")
}
else if (length(model.names) != length(l)) {
stop(paste("There are", length(l), "models, but you provided",
length(model.names), "names for them."))
}
else {
if (dcolumn == TRUE) {
for (i in 1:length(l)) {
string <- paste(string, " & \\multicolumn{1}{c}{",
model.names[i], "}", sep = "")
}
}
else {
for (i in 1:length(l)) {
string <- paste(string, " & ", model.names[i],
sep = "")
}
}
}
}
else if (!is.na(model.names) & class(model.names) != "character") {
stop("Model names must be specified as a vector of strings.")
}
else if (class(model.names) == "character" & length(model.names) !=
length(l)) {
stop(paste("A single model name was specified. But there are in fact",
length(l), "models."))
}
else if (class(model.names) == "character") {
if (dcolumn == TRUE) {
string <- paste(string, " & \\multicolumn{1}{c}{",
model.names, "}", sep = "")
}
else {
string <- paste(string, " & ", model.names, sep = "")
}
}
else {
if (dcolumn == TRUE) {
for (i in 1:length(l)) {
string <- paste(string, " & \\multicolumn{1}{c}{Model ",
i, "}", sep = "")
}
}
else {
for (i in 1:length(l)) {
string <- paste(string, " & Model ", i, sep = "")
}
}
}
if (booktabs == TRUE) {
string <- paste(string, " \\\\\n", "\\midrule\n", sep = "")
}
else {
string <- paste(string, " \\\\\n", "\\hline\n", sep = "")
}
if (single.row == TRUE) {
output.matrix <- matrix(ncol = (length(m)/3) + 1, nrow = length(m[,
1]))
for (i in 1:length(rownames(m))) {
output.matrix[i, 1] <- rownames(m)[i]
}
for (i in 1:length(m[, 1])) {
j <- 1
k <- 2
while (j <= length(m)) {
if (is.na(m[i, j])) {
output.matrix[i, k] <- ""
}
else if (m[i, j] == -Inf) {
output.matrix[i, k] <- "-Inf (NA)"
}
else {
std <- paste(" \\; (", coef.to.string(m[i,
j + 1], leading.zero), ")", sep = "")
if (strong.signif == TRUE) {
if (m[i, j + 2] <= 0.001) {
p <- "^{***}"
}
else if (m[i, j + 2] <= 0.01) {
p <- "^{**}"
}
else if (m[i, j + 2] <= 0.05) {
p <- "^{*}"
}
else if (m[i, j + 2] <= 0.1) {
p <- paste("^{", symbol, "}", sep = "")
}
else {
p <- ""
}
}
else {
if (m[i, j + 2] <= 0.01) {
p <- "^{***}"
}
else if (m[i, j + 2] <= 0.05) {
p <- "^{**}"
}
else if (m[i, j + 2] <= 0.1) {
p <- "^{*}"
}
else {
p <- ""
}
}
if (dcolumn == TRUE) {
dollar <- ""
}
else {
dollar <- "$"
}
entry <- paste(dollar, coef.to.string(m[i,
j], leading.zero), std, p, dollar, sep = "")
output.matrix[i, k] <- entry
}
k <- k + 1
j <- j + 3
}
}
}
else {
output.matrix <- matrix(ncol = (length(m)/3) + 1, nrow = 2 *
length(m[, 1]))
for (i in 1:length(rownames(m))) {
output.matrix[(i * 2) - 1, 1] <- rownames(m)[i]
output.matrix[(i * 2), 1] <- ""
}
for (i in 1:length(m[, 1])) {
j <- 1
k <- 2
while (j <= length(m)) {
if (is.na(m[i, j])) {
output.matrix[(i * 2) - 1, k] <- ""
output.matrix[(i * 2), k] <- ""
}
else if (m[i, j] == -Inf) {
output.matrix[(i * 2) - 1, k] <- "-Inf"
output.matrix[(i * 2), k] <- "(NA)"
}
else {
if (strong.signif == TRUE) {
if (m[i, j + 2] <= 0.001) {
p <- "^{***}"
}
else if (m[i, j + 2] <= 0.01) {
p <- "^{**}"
}
else if (m[i, j + 2] <= 0.05) {
p <- "^{*}"
}
else if (m[i, j + 2] <= 0.1) {
p <- paste("^{", symbol, "}", sep = "")
}
else {
p <- ""
}
}
else {
if (m[i, j + 2] <= 0.01) {
p <- "^{***}"
}
else if (m[i, j + 2] <= 0.05) {
p <- "^{**}"
}
else if (m[i, j + 2] <= 0.1) {
p <- "^{*}"
}
else {
p <- ""
}
}
if (dcolumn == TRUE) {
dollar <- ""
}
else {
dollar <- "$"
}
output.matrix[(i * 2) - 1, k] <- paste(dollar,
coef.to.string(m[i, j], leading.zero), p,
dollar, sep = "")
output.matrix[(i * 2), k] <- paste(dollar,
"(", coef.to.string(m[i, j + 1], leading.zero),
")", dollar, sep = "")
}
k <- k + 1
j <- j + 3
}
}
}
if (dcolumn == TRUE) {
dollar <- ""
}
else {
dollar <- "$"
}
gof.matrix <- matrix(nrow = nrow(gofs), ncol = ncol(gofs) +
1)
for (i in 1:length(gofs[, 1])) {
gof.matrix[i, 1] <- rownames(gofs)[i]
for (j in 1:length(gofs[1, ])) {
strg <- coef.to.string(gofs[i, j], leading.zero)
rn <- rownames(gofs)[i]
if (rn == "Num. obs." | rn == "n" | rn == "N" | rn ==
"N obs" | rn == "N obs." | rn == "nobs" | rn ==
"n obs" | rn == "n obs." | rn == "n.obs." | rn ==
"N.obs." | rn == "N. obs" | rn == "Num observations" |
rn == "Number of observations" | rn == "Num obs" |
rn == "num obs" | rn == "Num. observations" |
rn == "Num Observations" | rn == "Num. Observations" |
rn == "Num. Obs." | rn == "Num.Obs." | rn ==
"Number obs." | rn == "Number Obs." | rn == "Number obs" |
rn == "Number Obs" | rn == "Number of Obs." |
rn == "Number of obs." | rn == "Number of obs" |
rn == "Number of Obs" | rn == "Obs" | rn == "obs" |
rn == "Obs." | rn == "obs.") {
strg <- substring(strg, 1, nchar(strg) - 3)
}
gof.matrix[i, j + 1] <- paste(dollar, strg, dollar,
sep = "")
}
}
output.matrix <- rbind(output.matrix, gof.matrix)
max.lengths <- numeric(length(output.matrix[1, ]))
for (i in 1:length(output.matrix[1, ])) {
max.length <- 0
for (j in 1:length(output.matrix[, 1])) {
if (nchar(output.matrix[j, i]) > max.length) {
max.length <- nchar(output.matrix[j, i])
}
}
max.lengths[i] <- max.length
}
for (i in 1:length(output.matrix[, 1])) {
for (j in 1:length(output.matrix[1, ])) {
nzero <- max.lengths[j] - nchar(output.matrix[i,
j])
zeros <- rep(" ", nzero)
zeros <- paste(zeros, collapse = "")
output.matrix[i, j] <- paste(output.matrix[i, j],
zeros, sep = "")
}
}
for (i in 1:(length(output.matrix[, 1]) - length(gof.names))) {
for (j in 1:length(output.matrix[1, ])) {
string <- paste(string, output.matrix[i, j], sep = "")
if (j == length(output.matrix[1, ])) {
string <- paste(string, " \\\\\n", sep = "")
}
else {
string <- paste(string, " & ", sep = "")
}
}
}
if (booktabs == TRUE) {
string <- paste(string, "\\midrule\n", sep = "")
}
else {
string <- paste(string, "\\hline\n", sep = "")
}
for (i in (length(output.matrix[, 1]) - (length(gof.names) -
1)):(length(output.matrix[, 1]))) {
for (j in 1:length(output.matrix[1, ])) {
string <- paste(string, output.matrix[i, j], sep = "")
if (j == length(output.matrix[1, ])) {
string <- paste(string, " \\\\\n", sep = "")
}
else {
string <- paste(string, " & ", sep = "")
}
}
}
if (booktabs == TRUE) {
string <- paste(string, "\\bottomrule\n", sep = "")
}
else {
string <- paste(string, "\\hline\n", sep = "")
}
string <- paste(string, "\\vspace{-2mm}\\\\\n", sep = "")
if (strong.signif == TRUE) {
string <- paste(string, "\\multicolumn{", length(l) +
1, "}{l}{\\textsuperscript{***}$p<0.001$, ", "\\textsuperscript{**}$p<0.01$, \\textsuperscript{*}$p<0.05$, ",
"\\textsuperscript{$", symbol, "$}$p<0.1$}\n", sep = "")
}
else {
string <- paste(string, "\\multicolumn{", length(l) +
1, "}{l}{\\textsuperscript{***}$p<0.01$, ", "\\textsuperscript{**}$p<0.05$, \\textsuperscript{*}$p<0.1$}\n",
sep = "")
}
string <- paste(string, "\\end{tabular}\n", sep = "")
if (table == TRUE) {
if (scriptsize == TRUE) {
string <- paste(string, "\\normalsize\n", sep = "")
}
string <- paste(string, "\\end{center}\n", sep = "")
string <- paste(string, "\\caption{", caption, "}\n",
sep = "")
string <- paste(string, "\\label{", label, "}\n", sep = "")
if (sideways == TRUE) {
t <- "sideways"
}
else {
t <- ""
}
string <- paste(string, "\\end{", t, "table}\n", sep = "")
}
cat(string)
return(string)
}
Keine Kommentare:
Kommentar veröffentlichen