Sonntag, 29. Juli 2012

follow up: using texreg with systemfit

 

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