# helpers and print functions for class
# Check if vector is integer ----------------------------------------------
checkIfInteger <- function(x) {
suppressWarnings(
test <- all.equal(x, as.integer(x), check.attributes = FALSE)
)
if (test == TRUE) {
return(TRUE)
} else {
return(FALSE)
}
}
# Determine Max width of column ------------------------------------------
DetermineColumnWidth <- function(x) {
# x <- as.character(x)
if (is.factor(x)) {
x <- as.character(x)
}
x <- max(sapply(x, nchar), na.rm = T)
return(x)
}
# Determine width of all columns ------------------------------------------
DetermineColumnWidths <- function(df, footer) {
# Determine width of data
data <- sapply(df, DetermineColumnWidth)
# Determine width of headers
header <- names(df)
header <- sapply(header, DetermineColumnWidth)
# determine width of footer (total row)
footer <- sapply(footer, DetermineColumnWidth)
# determine max of header, data, and footer
results <- ifelse(header > data, header, data)
results <- ifelse(results > footer, results, footer)
return(results)
}
# Generic function to lay out table as desired ---------------------------------
print_console_helper <- function(df,
inner_table_padding = getOption("simplefreqs.inner_table_padding", default = 5),
row_divider_symbol = getOption("simplefreqs.row_divider_symbol", default = "\u2500"),
table_symbol = getOption("simplefreqs.table_symbol", default = "\u2550"),
print_table_symbol = getOption("simplefreqs.print_table_symbol", default = TRUE),
print_total_row = getOption("simplefreqs.print_table_total_row", default = TRUE),
print_metadata = getOption("simplefreqs.print_table_metadata", default = FALSE),
print_header_divider = getOption("simplefreqs.print_header_divider", default = TRUE)) {
# Set Constants
space_symbol <- " "
big_mark <- getOption("simplefreqs.big_mark", default = ",")
n <- sum(df$Freq)
decimal_digits <- getOption("simplefreqs.decimal_digits", default = 1)
# Replace NA with <NA> for printing
# We check if <NA> alrady exist in data.frame and issues warning if it does
lab <- levels(df[[1]])
if ("<NA>" %in% lab) {
warning('the string "<NA>" was detected. This conflicts with the printed NA results')
}
lab[is.na(lab)] <- "<NA>"
levels(df[[1]]) <- lab
missing <- attr(df, "na", exact = T)
missingRemoved <- attr(df, "na_removed", exact = T)
if (!is.null(missingRemoved)) {
norig <- sum(df$Freq) + missing
} else {
norig <- sum(df$Freq)
}
naPercent <- (missing / norig) * 100
# Determine if freqs are all integer or not (due to weighting)
allInteger <- checkIfInteger(df[[2]])
# Convert Dataframe to all character
# format as specified
df[1] <- as.character(df[[1]])
if (allInteger == TRUE) {
df[2] <- formatC(df[[2]], format = "f", digits = 0, big.mark = big_mark)
df[4] <- formatC(df[[4]], format = "f", digits = 0, big.mark = big_mark)
} else {
df[2] <- formatC(df[[2]], format = "f", digits = 1, big.mark = big_mark)
df[4] <- formatC(df[[4]], format = "f", digits = 1, big.mark = big_mark)
}
df[3] <- formatC(df[[3]] * 100, format = "f", digits = decimal_digits)
df[5] <- formatC(df[[5]] * 100, format = "f", digits = decimal_digits)
# Format Footer
if (allInteger == TRUE){
footer <- c(
"Total",
formatC(n, format = "f", digits = 0, big.mark = big_mark),
"100%",
"",
"")
} else {
footer <- c(
"Total",
formatC(n, format = "f", digits = decimal_digits, big.mark = big_mark),
"100%",
"",
""
)
}
maxColWidth <- DetermineColumnWidths(df, footer)
# add margins to columns
maxColWidth <- maxColWidth + inner_table_padding
maxLength <- sum(maxColWidth)
# get column names
nme <- names(df)
# Print Metadata ---------------------------------------------------------
if (print_metadata == TRUE) {
cat("\nVariable: ", attr(df, "title"), "\n", sep = "")
cat("Class: ", attr(df, "varClass", exact = T), "\n", sep = "")
if (!is.null(missingRemoved)) {
cat(paste0("NAs (removed): ", prettyNum(missing, big.mark = big_mark), " (", formatC(naPercent, digits = decimal_digits, format = "f"), "%)\n"))
} else {
cat(paste0("NAs: ", prettyNum(missing, big.mark = big_mark), " (", formatC(naPercent, digits = decimal_digits, format = "f"), "%)\n"))
}
}
# Print Table top ---------------------------------------------------------
if (print_table_symbol == TRUE) {
cat(rep(table_symbol, maxLength + 2), "\n", sep = "")
}
# Print Header ------------------------------------------------------------
# padding for header labels
for (col in 1:length(df)) {
colSize <- maxColWidth[col]
# determine padding
cellSize <- nchar(nme[col])
padding <- colSize - cellSize
startPadding <- padding
endPadding <- 0
cat(rep(space_symbol, startPadding), nme[[col]], rep(space_symbol, endPadding), sep = "")
}
cat("\n")
if (print_header_divider == TRUE) {
cat(rep(row_divider_symbol, maxLength + 2), "\n", sep = "")
}
# Cell Values -------------------------------------------------------------
for (row in 1:nrow(df)) {
for (col in 1:length(df)) {
colSize <- maxColWidth[col]
# determine padding
if (is.na(df[row, col])) {
cellSize <- 2
} else {
cellSize <- nchar(df[row, col])
}
padding <- colSize - cellSize
cat(rep(space_symbol, padding), df[[row, col]], sep = "")
}
cat("\n")
}
# Total Row ---------------------------------------------------------------
if (print_total_row == T) {
cat(rep(row_divider_symbol, maxLength + 2), "\n", sep = "")
for (col in 1:length(df)) {
colSize <- maxColWidth[col]
# determine padding
cellSize <- nchar(footer[col])
padding <- colSize - cellSize
startPadding <- padding
endPadding <- 0
cat(rep(space_symbol, startPadding), footer[[col]], rep(space_symbol, endPadding), sep = "")
}
cat("\n")
}
# Table Bottom ------------------------------------------------------------
if (print_table_symbol == T) {
cat(rep(table_symbol, maxLength + 2), "\n", sep = "")
}
}
print_markdown_helper <- function(df) {
# Set constants
nme <- attr(df, "title", exact = T)
decimal_mark <- getOption("OutDec", default = ".")
decimal_digits <- getOption("simplefreqs.decimal_digits", default = 1)
big_mark <- getOption("simplefreqs.big_mark", default = ",")
# Replace NA with <NA> for printing
# We check if <NA> alrady exist in data.frame and issues warning if it does
lab <- levels(df[[1]])
if ("<NA>" %in% lab) {
warning('the string "<NA>" was detected. This conflicts with the printed NA results')
}
lab[is.na(lab)] <- "<NA>"
levels(df[[1]]) <- lab
# Determine if freqs are all integer or not (due to weighting)
allInteger <- checkIfInteger(df[[2]])
# Built GT table
x <- df %>%
gt(rowname_col = nme) %>%
tab_stubhead(label = nme)
# Align columns
x <- cols_align(x, align = "right", columns = c(1))
# Format freq columns as integers if all integers
if (allInteger == TRUE) {
x <- fmt_number(x, columns = c(2, 4), sep_mark = big_mark, dec_mark = decimal_mark, decimals = 0)
} else {
x <- fmt_number(x, columns = c(2, 4), sep_mark = big_mark, dec_mark = decimal_mark, decimals = decimal_digits)
}
# Format percents
x<- fmt_number(x, columns = c(3, 5), scale_by = 100, dec_mark = decimal_mark, decimals = decimal_digits)
# Add total row
print_total_row <- getOption("simplefreqs.print_table_total_row", default = TRUE)
if (print_total_row==TRUE){
# Format freq column as integers if all integers
if (allInteger == TRUE) {
x <- grand_summary_rows(x,columns = c(2,3), missing_text = "",
fns = list (Total = ~ sum(.)),
fmt = list(
~ fmt_number(., columns = c("Freq"), dec_mark=decimal_mark, sep_mark=big_mark, decimals=0),
~ fmt_percent(., columns = c("%"), decimals=0)
)
)
} else {
x <- grand_summary_rows(x,columns = c(2,3), missing_text = "",
fns = list (Total = ~ sum(.)),
fmt = list(
~ fmt_number(., columns = c("Freq"), dec_mark=decimal_mark, sep_mark=big_mark, decimals=decimal_digits),
~ fmt_percent(., columns = c("%"), decimals=0)
)
)
}
x <- tab_style(x,
style = cell_text(align = "right"),
locations = cells_stub_grand_summary()
)
}
table.width = getOption("simplefreqs.table.width", default=50)
table.padding = getOption("simplefreqs.inner_table_padding", default=10)
# Format table using options
x <- tab_options(x, table.width = pct(table.width),
stub.border.style=NULL,
stub.border.width=0,
grand_summary_row.border.style = "solid",
grand_summary_row.border.width = "2pt",
grand_summary_row.border.color = "darkgray",
data_row.padding.horizontal = paste0(table.padding, "pt"),
grand_summary_row.padding.horizontal = paste0(table.padding, "pt"),
column_labels.padding.horizontal = paste0(table.padding, "pt")
)
table_border <- getOption("simplefreqs.print_table_symbol", default = TRUE)
if (table_border == TRUE){
x <- tab_options(x,
table.border.top.style = "double",
table.border.top.width = "4pt",
table.border.top.color = "darkgray",
table.border.bottom.style = "double",
table.border.bottom.width = "4pt",
table.border.bottom.color = "darkgray")
}else{
x <- tab_options(x,
table.border.top.style = "hidden",
table.border.top.width = "0pt",
table.border.bottom.style = "hidden",
table.border.bottom.width = "0pt")
}
header_divider <- getOption("simplefreqs.print_header_divider", default=TRUE)
if (header_divider==TRUE){
x <- tab_options(x,
column_labels.border.bottom.style = "solid",
column_labels.border.bottom.width = "2pt",
column_labels.border.bottom.color = "darkgray")
} else{
x <- tab_options(x,
column_labels.border.bottom.style = "hidden",
column_labels.border.bottom.width = "0pt")
}
# Further table formatting using styles
x <- tab_style(x,
style = cell_text(align = "right"),
locations = cells_stubhead()
)
x <- tab_style(x,
style = cell_borders(weight = px(0)),
locations = cells_body()
)
x <- tab_style(x,
style = cell_borders(weight = px(0)),
locations = cells_stub()
)
# Print Metadata ---------------------------------------------------------
print_metadata = getOption("simplefreqs.print_table_metadata", default = FALSE)
missing <- attr(df, "na", exact = T)
missingRemoved <- attr(df, "na_removed", exact = T)
if (!is.null(missingRemoved)) {
norig <- sum(df$Freq) + missing
} else {
norig <- sum(df$Freq)
}
naPercent <- (missing / norig) * 100
if (print_metadata == TRUE) {
meta <- paste0("Variable: ", attr(df, "title"), "<br>",
"Class: ", attr(df, "varClass", exact = T), "<br>")
if (!is.null(missingRemoved)) {
meta <- paste0(meta, "NAs (removed): ", prettyNum(missing, big.mark = big_mark), " (", formatC(naPercent, digits = decimal_digits, format = "f"), "%)")
} else {
meta <- paste0(meta, "NAs: ", prettyNum(missing, big.mark = big_mark), " (", formatC(naPercent, digits = decimal_digits, format = "f"), "%)")
}
x <- tab_source_note(x, md(meta))
x <- tab_style(x,
style = cell_text(align = "right"),
locations = cells_source_notes()
)
}
return(x)
}
#' @export
print.simplefreqs_freq <- function(x, ...) {
# Rename columns for printing
names(x) <- c(attr(x, "title", exact = T), "Freq", "%", "Cum. Freq", "Cum. %")
# Plot results
plot <- attr(x, "plotted", exact = T)
if (plot == TRUE) {
nme <- attr(x, "title", exact = T)
gg <- ggplot(data = x, aes(.data[[nme]], .data$Freq))
gg <- gg + geom_bar(stat = "identity")
gg <- gg + theme_minimal() + ggtitle(paste("Frequency:", nme)) + ylab("Count")
gg <- gg + theme(axis.text.x = element_text(angle = 90, hjust = 1))
print(gg)
}
# Print table
markdown <- attr(x, "markdown", exact = T)
if (markdown == FALSE) {
print_console_helper(x)
} else {
y<- print_markdown_helper(x)
fun <- utils::getFromNamespace("knit_print.gt_tbl", "gt")
return(fun(y))
#return(gt:::knit_print.gt_tbl(y)) # ::: is not allowed on CRAN
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.