Skip to content

Commit

Permalink
Merge pull request #33 from Crunch-io/Latex-cleanup
Browse files Browse the repository at this point in the history 
Latex cleanup
  • Loading branch information
@persephonet
persephonet authored Jun 19, 2018
2 parents 3e4fd08 + 4cda1a8 commit ad944c9
Show file tree
Hide file tree
Showing 10 changed files with 510 additions and 181 deletions.
10 changes: 5 additions & 5 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,19 +46,19 @@ S3method(setResults,ToplineCategoricalGeneral)
S3method(setResults,ToplineMultipleResponse)
S3method(setResults,ToplineNumeric)
S3method(setResults,default)
S3method(toplineHeader,ToplineCategoricalArray)
S3method(toplineHeader,default)
S3method(writeLatex,Crosstabs)
S3method(writeLatex,Toplines)
S3method(writeLatex,default)
S3method(tableHeader,ToplineCategoricalArray)
S3method(tableHeader,ToplineVar)
export(banner)
export(crosstabs)
export(themeDefaultExcel)
export(themeDefaultLatex)
export(themeHuffPoCrosstabs)
export(themeHuffPoToplines)
export(themeNew)
export(themeUKPolitical)
export(writeExcel)
export(writeLatex)
export(writeLatex.default)
importFrom(crunch,alias)
importFrom(crunch,aliases)
importFrom(crunch,allVariables)
Expand Down
39 changes: 35 additions & 4 deletions R/theme.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -108,10 +108,10 @@ themeNew <- function(..., default_theme = themeDefaultExcel()){
if (length(unlist(validators_to_use[[nm]]["include"])) > 1) {
default_theme[[nm]] <- list()
for (incl in setdiff(validators_to_use[[nm]]$include, dots[[nm]])) {
if (incl %in% names(default_theme)) {
default_theme[[nm]][[incl]] <- default_theme[[incl]]
} else if (as.logical(validators_to_use[[incl]]["missing"])) {
if (as.logical(validators_to_use[[incl]]["missing"])) {
next
} else if (incl %in% names(default_theme)) {
default_theme[[nm]][[incl]] <- default_theme[[incl]]
} else if (!is.null(validators_to_use[[incl]]["default"]) && !is.na(validators_to_use[[incl]]["default"])) {
rsp <- unlist(validators_to_use[[incl]]["default"])
if (validators_to_use[[incl]]["class"] %in% "logical") { default_theme[[nm]][[incl]] <- as.logical(rsp) }
Expand Down Expand Up @@ -204,7 +204,7 @@ themeDefaultExcel <- function(font = getOption("font", default = "Calibri"),
themeDefaultLatex <- function(font = getOption("font", default = "helvet"),
font_size = getOption("font_size", default = 12)){

norm <- list(font = font, font_size = font_size)
norm <- list(font = font, font_size = NULL)
defaults <- list(font = font, font_size = font_size,
format_title = list(font_size = font_size + 4, decoration = "bold"),
format_subtitle = list(font_size = font_size, decoration = "bold"),
Expand Down Expand Up @@ -460,3 +460,34 @@ themeUKPolitical <- function() {
latex_foottext = "",
latex_multirowheaderlines = FALSE)
}

#' @export
themeHuffPoToplines <- function(logo = NULL) {
themeNew(default_theme = themeDefaultLatex(),
logo = logo,
format_title = list(decoration = "bold"),
format_var_description = list(include_q_number = TRUE, decoration = "bold",
background_color = "gray"),
format_var_filtertext = list(decoration = "italic", font_size = 8),
format_totals_row = NULL,
format_unweighted_n = NULL,
latex_headtext = "tbc",
latex_foottext = "tbc",
one_per_sheet = FALSE)
}
#' @export
themeHuffPoCrosstabs <- function(logo = NULL) {
themeNew(default_theme = themeDefaultLatex(),
logo = logo,
format_title = list(decoration = "bold"),
format_subtitle = list(decoration = "bold"),
format_min_base = list(min_base = 30, mask = "*"),
format_var_name = list(include_q_number = TRUE, decoration = "bold"),
format_var_description = list(include_q_number = FALSE),
format_var_filtertext = list(decoration = "italic", font_size = 8),
format_unweighted_n = list(latex_add_parenthesis = TRUE),
latex_headtext = "tbc",
latex_foottext = "tbc",
one_per_sheet = TRUE)
}

40 changes: 10 additions & 30 deletions R/writeData.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -109,22 +109,7 @@ munge_var <- function(var, banner_name, theme, proportions, banner_info, latex)
rownames(data) <- paste0(theme_dt$name,
if (weight_v && !is.null(dim(data)) && nrow(data) == 2) c(": Min", ": Max"))
}
if (latex && prop_v) {
data[] <- round(data, rdig)
data[] <- format(data, nsmall=theme$digits, big.mark=",")
data[] <- apply(data, 2, trimws)
if (proportions) { data[] <- apply(data, 2, paste0, "%") }
}
if (latex && weight_v) {
data[] <- trimws(format(data, big.mark=","))
if (theme_dt$latex_add_parenthesis) {
data[] <- apply(data, 2, paste_around, "(", ")")
}
if (!is.null(theme_dt$latex_adjust)) {
data[] <- apply(data, 2, paste_around, paste0("\\multicolumn{1}{", theme_dt$latex_adjust, "}{"), "}")
}
}


data <- setNames(as.data.frame(data, stringsAsFactors = FALSE),
unlist(lapply(banner_info$multicols, function(x) c(x, if (banner_info$empty_col && !latex) "empty"))))

Expand All @@ -137,25 +122,18 @@ munge_var <- function(var, banner_name, theme, proportions, banner_info, latex)
unweighted_n <- as.matrix(unweighted_n[rep(1, length(var$inserts)), ], nrow = length(var$inserts),
ncol = ncol(unweighted_n), byrow = TRUE)
unweighted_n[var$inserts %in% "Heading", ] <- NA
if (latex) {
data_list$body[var$inserts %in% "Heading", ] <- ""
}
}

# if (is.null(theme$format_min_base$min_base)) theme$format_min_base$min_base <- 0
mask_vars <- c("totals_row", "means", "medians")
min_cell <- matrix(suppressWarnings(as.numeric(as.character(unweighted_n))) < theme$format_min_base$min_base, nrow = nrow(unweighted_n), ncol = ncol(unweighted_n))
min_cell_rep <- suppressWarnings(as.numeric(as.character(apply(unweighted_n, 2, min, na.rm=TRUE)))) < theme$format_min_base$min_base
min_cell <- matrix(suppressWarnings(as.numeric(as.character(unweighted_n))) <
theme$format_min_base$min_base, nrow = nrow(unweighted_n), ncol = ncol(unweighted_n))
min_cell_rep <- colSums(min_cell, na.rm = TRUE) > 0
top_sub <- mask_vars %in% top
min_cell_top <- if (any(top_sub)) matrix(min_cell_rep, nrow = sum(top_sub), ncol = ncol(unweighted_n))
bottom_sub <- mask_vars %in% bottom
min_cell_bottom <- if (any(bottom_sub)) matrix(min_cell_rep, nrow = sum(bottom_sub), ncol = ncol(unweighted_n))
if (latex && !is.null(theme$format_min_base$mask)) {
for (x in intersect(data_order, mask_vars)) {
data_list[[x]][,min_cell_rep] <- theme$format_min_base$mask
}
data_list$body[min_cell] <- theme$format_min_base$mask
}


if (is(var, "ToplineCategoricalArray") && latex) {
rownames(data_list$body) <- sapply(var$inserts_obj, name)
data_list <- lapply(data_list, function(x) {
Expand All @@ -164,8 +142,10 @@ munge_var <- function(var, banner_name, theme, proportions, banner_info, latex)
})
}

return(list(top = top, bottom = bottom, data_order = data_order, inserts = var$inserts, data_list = data_list,
min_cell_top = min_cell_top, min_cell_body = min_cell, min_cell_bottom = min_cell_bottom))
return(structure(list(top = top, bottom = bottom, data_order = data_order,
inserts = var$inserts, data_list = data_list, min_cell_top = min_cell_top,
min_cell_body = min_cell, min_cell_bottom = min_cell_bottom,
min_cell = min_cell_rep), class = class(var)))
}

var_header <- function(var, theme) {
Expand Down
179 changes: 153 additions & 26 deletions R/writeLatex.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -43,10 +43,49 @@ writeLatex <- function(data_summary, theme = themeDefaultLatex(),
if (pdf && is.null(filename)) {
stop("Please provide a file name to generate PDF output.")
}

theme_validator(theme)

UseMethod("writeLatex", data_summary)
wrong_class_error(data_summary, "CrunchTabs", "data_summary")
if (!any(c("Toplines", "Crosstabs") %in% class(data_summary))) {
stop("The expected class for `data_summary` is either Toplines, CrunchTabs or Crosstabs CrunchTabs, not ", collapse_items(class(data_summary)))
}

topline <- is(data_summary, "Toplines")
if (is.null(theme$font_size)) { theme$font_size <- 12 }
theme$proportions <- proportions

headers <- lapply(data_summary$results, tableHeader, theme = theme)

data_summary$results <- lapply(data_summary$results, rm_inserts, theme)
results <- reformatLatexResults(data_summary, proportions = proportions, theme = theme)
bodies <- lapply(results, function (x)
sapply(x, latexTable.body, theme = theme, topline = topline))

out <- c(
latexDocHead(theme = theme, title = title, subtitle = subtitle, topline = topline),
if (!topline) sapply(seq_along(data_summary$banner), function (j) {
longtableHeadFootB(data_summary$banner[[j]], num = j, page_width = 9,
theme = theme)
}),
latexStart(table_of_contents = table_of_contents, sample_desc = sample_desc,
field_period = field_period, moe = moe, font_size = theme$font_size),
sapply(seq_along(data_summary$results), function(i) {
c(paste(headers[[i]], bodies[[i]], latexTableFoot(topline = topline),
sep="\n", collapse="\n"),
if (theme$one_per_sheet) { "\\clearpage" })
}),
append_text,
latexDocFoot()
)
if (!is.null(filename)) {
filename <- paste0(filename, ".tex")
cat(out, sep = "\n", file = filename)
if (pdf) {
if (logging) { print("PDF-ing") }
pdflatex(filename, open, path.to.pdflatex = Sys.which("pdflatex"))
}
}
return(invisible(data_summary))
}


Expand All @@ -56,34 +95,98 @@ writeLatex.default <- function(data_summary, ...) {
collapse_items(class(data_summary)), "'.")
}

latexTable.body <- function(df, topline) {
latexTable.body <- function(df, theme, topline) {

body <- df$data_list$body
if (topline || length(intersect(c("totals_row", "unweighted_n", "weighted_n"), c(df$top, df$bottom))) == 0) {
summary <- NULL
} else {
summary <- do.call(rbind, lapply(intersect(c("totals_row", "unweighted_n", "weighted_n"), c(df$top, df$bottom)), function(x) {
df$data_list[[x]]
}))
data <- df$data_list
for (nm in intersect(c("body", "totals_row"), names(data))) {
data[[nm]][] <- round(data[[nm]], theme$digits)
data[[nm]][] <- format(data[[nm]], nsmall=theme$digits, big.mark=",")
data[[nm]][] <- apply(data[[nm]], 2, trimws)
if (theme$proportions) { data[[nm]][] <- apply(data[[nm]], 2, paste0, "%") }
}
for (nm in intersect(c("unweighted_n", "weighted_n"), names(data))) {
nm2 <- paste0("format_", nm)
data[[nm]][] <- trimws(format(data[[nm]], big.mark=","))
if (theme[[nm2]]$latex_add_parenthesis) {
data[[nm]][] <- apply(data[[nm]], 2, paste_around, "(", ")")
}
if (!is.null(theme[[nm2]]$latex_adjust) && !topline) {
data[[nm]][] <- apply(data[[nm]], 2, paste_around,
paste0("\\multicolumn{1}{", theme[[nm2]]$latex_adjust, "}{"), "}")
}
}

if (!is.null(rownames(body))) body <- data.frame(rownames(body), body, stringsAsFactors = FALSE)
if (!is.null(rownames(summary))) summary <- data.frame(rownames(summary), summary, stringsAsFactors = FALSE)
for (j in 1:ncol(body)) body[, j] <- escM(body[, j])
if (!is.null(summary)) for (j in 1:ncol(summary)) summary[, j] <- escM(summary[, j])

collapsestring <- "\\\\\n"

sepstring <- if (topline && ncol(body) == 2) { " \\hspace*{0.15em} \\dotfill " } else { " & " }
if (topline) body[[1]] <- paste0(" & ", body[[1]])
if (topline) {
return(paste(paste(apply(rbind(body, summary), 1, paste, collapse = sepstring), collapse = collapsestring),
collapsestring))
} else {
body <- paste(paste(apply(body, 1, paste, collapse = sepstring), collapse = collapsestring), collapsestring)
summary <- paste(paste(apply(summary, 1, paste, collapse = sepstring), collapse = collapsestring), collapsestring)
return(paste(body, "\\midrule", summary))
mask_vars <- c("totals_row", "means", "medians")
if (!is.null(theme$format_min_base$min_base) && any(df$min_cell_body)) {
if (!is.null(theme$format_min_base$mask)) {
data$body[df$min_cell_body] <- theme$format_min_base$mask
for (nm in intersect(mask_vars, names(data))) {
data[[nm]][, df$min_cell] <- theme$format_min_base$mask
}
}
for (i in which(colSums(df$min_cell_body) != 0)) {
data$body[df$min_cell_body[,i], i] <- latexDecoration(data$body[df$min_cell_body[,i], i], theme$format_min_base)
for (nm in intersect(mask_vars, names(data))) {
data[[nm]][, df$min_cell] <- latexDecoration(data[[nm]][, df$min_cell], theme$format_min_base)
}
}
}

data <- lapply(data, function(dt) {
matrix(apply(data.frame(rownames(dt), dt, stringsAsFactors = FALSE), 2, escM),
nrow = nrow(dt))
})

for (nm in intersect(gsub("format_", "", names(theme)), names(data))) {
data[[nm]][] <- apply(data[[nm]], 2, latexDecoration, theme[[paste0("format_", nm)]])
}

for (i in which(df$inserts %in% c("Heading"))) {
data$body[i, 2:ncol(data$body)] <- ""
data$body[i, ] <- latexDecoration(data$body[i, ], theme$format_headers)
}
for (i in which(df$inserts %in% c("Subtotal"))) {
data$body[i, ] <- latexDecoration(data$body[i, ], theme$format_subtotals)
}

# body <- data$body
# summary <- do.call(rbind, data[intersect(c("means", "totals_row", "unweighted_n", "weighted_n"), df$data_order)])
# # if (topline || length(intersect(c("totals_row", "unweighted_n", "weighted_n"), df$data_order)) == 0) {
# # summary <- NULL
# # } else {
# # summary <- do.call(rbind, lapply(intersect(c("totals_row", "unweighted_n", "weighted_n"), df$data_order), function(x) {
# # data[[x]]
# # }))
# # }

collapsestring <- "\\\\\n"

sepstring <- if (topline && ncol(data$body) == 2) {
" \\hspace*{0.15em} \\dotfill "
} else { " & " }

data <- lapply(data, function(dt) {
paste(paste(paste0(if (topline) " & ", apply(dt, 1, paste, collapse = sepstring)),
collapse = collapsestring), collapsestring)
})

if (is(df, "ToplineCategoricalArray")) df$data_order <- "body"
a <- paste(paste0(data[intersect(c("body", "medians", "means"), df$data_order)],
collapse = ""), if (!topline) "\\midrule",
paste0(data[intersect(c("totals_row", "weighted_n", "unweighted_n"), df$data_order)],
collapse = ""))
#
# if (topline) {
# bod <- do.call(rbind, list(body, if (!is(df, "ToplineCategoricalArray")) summary))
# bod[,1] <- paste0(" & ", bod[,1])
# b <- (paste(paste(apply(bod, 1, paste, collapse = sepstring), collapse = collapsestring),
# collapsestring))
# } else {
# body <- paste(paste(apply(body, 1, paste, collapse = sepstring), collapse = collapsestring), collapsestring)
# if (!is.null(summary)) summary <- paste(paste(apply(summary, 1, paste, collapse = sepstring), collapse = collapsestring), collapsestring)
# b <- (paste(body, "\\midrule", summary))
# }
return(a)
}


Expand Down Expand Up @@ -202,9 +305,16 @@ latexDecoration <- function(item, item_theme) {
if (!is.null(item_theme$font_size)) {
item <- paste0(fontLine(item_theme$font_size), item)
}
if (!is.null(item_theme$font_color)) {
item <- paste0("\\color{", item_theme$font_color, "}", item)
}
return(item)
}

tableHeader <- function(x, theme) {
UseMethod("tableHeader", x)
}

latexTableFoot <- function(topline) {
if (topline) {
return("\n\\end{longtable}\n\\end{center}\n\n")
Expand All @@ -213,6 +323,23 @@ latexTableFoot <- function(topline) {
}
}

latexTableName <- function(var, theme) {
var_info <- var_header(var, theme)
col <- if (is.null(theme[[names(var_info)[[1]]]]$background_color)) { "white"
} else { theme[[names(var_info)[[1]]]]$background_color }
if (!is.null(var_info$format_var_subname) && names(var_info)[1] != "format_var_subname") {
var_info[[1]] <- paste0(var_info[[1]], if (!is.null(var_info$format_var_subname))
paste0(" — ", var_info$format_var_subname))
var_info$format_var_subname <- NULL
}
if (length(var_info) == 0) var_info <- list(format_var_name = paste0("\\color{", col, "}{404}"))
paste("\\colorbox{", col, "}{\n",
"\\addcontentsline{lot}{table}{ ", escM(var_info[[1]]), "}\n",
"\\parbox{", if (is(var, "ToplineVar")) { "6.5" } else { "9" }, "in}{\n",
paste0("\\", gsub("_", "", names(var_info)), "{", escM(var_info), "}", collapse = "\\\\ \n"),
"}} \\\\", sep="")
}

latexDocFoot <- function() { return("\n}\n\\end{document}\n") }


Loading

0 comments on commit ad944c9

Please sign in to comment.