R/formatr.R

In bdempe18/rchitex: Creates Nicely Format Text and Latex Tables

sig_at <- function(v, sigs) {
  sa <- unlist(lapply(v, function(x) {
    tryCatch({
      names(sigs[x <= sigs])[[1]]
    }, error = function(e) ''
    )}))
  sa[is.na(sa)] <- ''
  sa
}

format_indep_names <- function(mods, indep_names=NA) {
  if (is.vector(indep_names))  return (indep_names)

  idn <- unique(unlist(lapply(mods, function(m) names(stats::coef(m)))))
  if ('(Intercept)' %in% idn) idn <- c(setdiff(idn, '(Intercept)'), '(Intercept)')

  idn <- as.list(idn)
  names(idn) <- idn
  if ('(Intercept)' %in% idn)
    idn['(Intercept)'] <- 'Constant'
  idn
}

f_to_string <- function(f_stat, mod_class='lm') {
  out <- NA
    if (mod_class == "plm") {
    out <- as.character(format(f_stat$statistic,
                               format='d', big.mark=','))
    } else {
      out <- format(f_stat[1], format='d', big.mark=',')[1]
  }

  out
}

center_text <- function(text, width) {
  n_blank <- (width - nchar(text))%/%2
  paste0(strrep(' ', n_blank), text, strrep(' ', width-n_blank-nchar(text)))
}

roundr_fac <- function(max_precision, min_digs=0) {
  roundr <- function(num, nsmall=min_digs) {
    if (!is.numeric(num)) return(num)
    format(round(as.numeric(unlist(num), use.names=F),
                 max_precision), big.mark=',', nsmall=nsmall)
  }
  roundr
}

get_ar2 <- function(mod, mod_class) {
  out <- ''
  if (mod_class == "plm") out <- mod$r.squared[2]
  else out <- mod$adj.r.squared
  out
}

get_wald <- function(mod, sig, roundr) {
  wald <- roundr(summary(mod)$wald)
  p_val <- lmtest::waldtest(mod)[[4]][2]

  paste0(wald, sig_at(p_val, sigs=sig), collapse='')

}

get_fits <- function(mods, stats='all', roundr, sig, custom_annotations=NA) {
  # <-- function returns a list of fit values
  # in the form of a list -->

  if (!is.character(stats))
    stop('Annotions should be a single string', .call=FALSE)

  fit_lst <- list('lm'    = 'oraf',
                  'glm'   = 'olc',
                  'plm'   = 'oraf',
                  'ivreg' = 'oras',
                  'tobit' = 'olw',
                  'rse'   = 'oraf')

  # mods may need to be coerced to list
  if (class(mods) != "list") mods <- list(mods)


  possibles <- c("Observations"   = function(m) roundr(stats::nobs(m), 0),
                 "R2" = function(m) summary(m)$r.squared[1],
                 "Adjusted R2"    = function(m) {
                   get_ar2(summary(m), class(m)[1]) },
                 "F Statistic"    = function(m)  {
                   f_to_string(roundr(summary(m)$fstatistic), class(m)[1]) },
                 "AIC"            = function(m) summary(m)$aic,
                 "Log Likelihood" = function(m) stats::logLik(m)[1],
                 "Res. SE"        = function(m) summary(m)$sigma,
                 "Wald Test"      = function(m) get_wald(m, sig, roundr))
  # if stats are specificed, just spc vals are searched
  if (stats == 'all') {
    stats <- lapply(mods, class)
    stats <- unlist(lapply(stats, function(s) s[1]))
    stats <- paste0(fit_lst[stats], collapse='')
  }

  aliases <- list('c' = 'AIC',
                  'f' = 'F Statistic',
                  'a' = 'Adjusted R2',
                  'r' = 'R2',
                  'o' = 'Observations',
                  'l' = 'Log Likelihood',
                  's' = 'Res. SE',
                  'w' = 'Wald Test')
  includes <- unique(unlist(strsplit(tolower(stats), '')))
  includes <- aliases[unlist(includes)]
  fit_char <- lapply(names(includes), function(p) {
    unlist(lapply(mods, function(m) {
      tryCatch({
        if  (grepl(p, fit_lst[class(m)[1]])) {
          roundr(possibles[[includes[[p]]]](m))
        } else ''
      }, error = function(e) NA)
    }), use.names=FALSE)
  })

  names(fit_char) <- names(possibles[unlist(includes)])

  if (!is.null(custom_annotations))
    fit_char <- c(custom_annotations, fit_char)

  fit_char <- lapply(fit_char, function(fc) {
    if (all(is.na(fc))) NULL
    else fc
  })

  Filter(Negate(is.null), fit_char)
}


gen_header <- function(code, type) {
  if (is.null(type)) return ('')

  header <- switch(type,
                   "latex" = "% Table generated by rchitex (Ben Dempe, 2019)\n",
                   "html"  = "<!-- Table generated by rchitex (Ben Dempe, 2019) -->\n",
                   "")

  paste0(header, code, collapse='', sep='\n')
}

group_labels <- function(grouped_label, n_mods, html=FALSE, missing='') {
  # calculates the number of columns needed
  # if any gl entry lists the starting and end cols, they are converted to a full column list
  # i.e c(1,3) -> 1,2,3

  expanded_gl <- unlist(lapply(grouped_label,
                               function(x) if (length(x)==1) x else seq(x[[1]], x[[2]])), use.names=FALSE)
  full <- seq(1:n_mods)
  full[setdiff(full, expanded_gl)] <- 'BLANK'
  full <- full[c(TRUE, !full[-length(full)] == full[-1])]
  n_cols <- length(full[full=='BLANK'])

  #h <- rep('<td></td>', n_cols + length(grouped_label))
  h <- rep(missing, n_cols + length(grouped_label))
  span <- 0
  for (i in names(grouped_label)) {
    col_len <- if(length(grouped_label[[i]])==1) 1 else grouped_label[[i]][[2]]-grouped_label[[i]][[1]]+1
    if (html) {
      h[grouped_label[[i]][[1]] - span] <- paste0('<td colspan=',
                                                  col_len,
                                                  ' style="border-bottom: 1px #ccc; border-top: 0">',
                                                  i, ' </td>\n', sep='', collapse='')
    } else {
      h[grouped_label[[i]][[1]] - span] <- col_len
      names(h)[grouped_label[[i]][[1]] - span] <- i
    }

    if (col_len > 1) span <- span + col_len-1
  }

  # ? not positive why I had to do this
  temp <- names(h)
  h <- as.numeric(h)
  names(h) <- temp

  h
}