Nothing
R/write_report_text.R
In reporter: Creates Statistical Reports
Defines functions
token_check
write_page_numbers
page_setup
write_content
paginate_content
write_report_text
update_page_numbers
create_content
create_report_text
# Special Functions for PDF and RTF ---------------------------------------
#' @title
#' Create a text report, but not on the file system
#'
#' @description
#' This function creates a report, using the
#' parameters provided in the report_spec object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
create_report_text <- function(rs) {
# Calculate available space for content
rs <- page_setup(rs)
# Get page template for easy access
pt <- rs$page_template
# Put content in new variable for easy access
ls <- rs$content
# Break content into pages
ret <- paginate_content(rs, ls)
# Assign table column widths back to report spec for reference
rs$column_widths <- ret[["widths"]]
# Assign graphics flag back to report spec
rs$has_graphics <- ret[["has_graphics"]]
# Assign pages to ls and continue processing
ls <- ret[["pages"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(ls[[1]]$pages))
ls[[1]]$pages <- ls[[1]]$pages[seq(1, rs$preview)]
}
# Combine all content pages
res <- create_content(rs, ls, pt)
rs <- res$rs
ls <- res$ls
# After report is created, fix the page numbers.
# Reason is we don't really know how many pages there are
# until the report is created.
upt <- update_page_numbers(rs, ls)
res <- list(rs = rs, ls = upt)
return(res)
}
#' @title Create content for PDF and RTF output type.
#' @description This loop prepares pages created in paginate_content
#' @noRd
create_content <- function(rs, ls, pt) {
ret <- list()
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
blank_margin_top <- rep("", rs$blank_margin_top)
blank_margin_left <- paste0(rep(" ", rs$blank_margin_left), collapse = "")
for (cont in ls) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(ls))
last_object <- TRUE
else
last_object <- FALSE
for (pg in cont$pages) {
page <- page + 1
# Vector to hold lines on a page
if (page_open == FALSE)
lns <- c()
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
if (rs$blank_margins)
lns <- append(lns, blank_margin_top)
#print(page_open)
if (page_open == FALSE) {
if (!is.null(pt$page_header))
lns <- append(lns, paste0(blank_margin_left, pt$page_header))
if (!is.null(pt$title_hdr)) {
tmp <- trimws(pad_any(pt$title_hdr, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
if (!is.null(pt$titles)) {
tmp <- trimws(pad_any(pt$titles, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
}
if (!is.null(pg)) {
tmp <- trimws(pad_any(pg, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(pt$footnotes)) {
tmp <- trimws(pad_any(pt$footnotes, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
if (!is.null(pt$page_footer))
lns <- append(lns, paste0(blank_margin_left, pt$page_footer))
# Increment total page count
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
# If page not open, add to list
ret[[length(ret) + 1]] <- lns
}
}
}
res <- list(rs = rs, ls = ret)
return(res)
}
#' @description Update page numbers in text file
#' @details Logic is to read in each line of the file, loop through and replace
#' tokens as needed. Pages numbers are incremented every time a form feed
#' is encountered. Total pages is retrieved from the report pages property.
#' Total pages is calculated when a page break occurs.
#' @noRd
update_page_numbers <- function(rs, lns) {
# Set up page variables
tpg <- rs$pages
# Define vectorized function to replace tokens
replace_tokens <- Vectorize(function(x, srch, just) {
ret <- x
# Replace tokens, but keep overall width the same
if (grepl(srch, x, fixed = TRUE)) {
#print("found it")
tmp <- sub("[tpg]", tpg, srch, fixed = TRUE)
tmp <- sub("[pg]", pg, tmp, fixed = TRUE)
tmp <- pad_any(tmp, nchar(srch), just)
ret <- sub(srch, tmp, x, fixed = TRUE)
}
return(ret)
}, USE.NAMES = FALSE)
for (pg in seq_along(lns)) {
# Call vectorized function on entire page header/footer segment
if (token_check(rs$page_header_left)) {
for (i in seq_len(length(rs$page_header_left))) {
if (token_check(rs$page_header_left[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_header_left[i], "left")
}
}
}
if (token_check(rs$page_header_right)) {
for (i in seq_len(length(rs$page_header_right))) {
if (token_check(rs$page_header_right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_header_right[i], "right")
}
}
}
if (token_check(rs$page_footer_left)) {
for (i in seq_len(length(rs$page_footer_left))) {
if (token_check(rs$page_footer_left[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_left[i], "left")
}
}
}
if (token_check(rs$page_footer_center)) {
for (i in seq_len(length(rs$page_footer_center))) {
if (token_check(rs$page_footer_center[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_center[i], "centre")
}
}
}
if (token_check(rs$page_footer_right)) {
for (i in seq_len(length(rs$page_footer_right))) {
if (token_check( rs$page_footer_right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_right[i], "right")
}
}
}
if (!is.null(rs$title_hdr)) {
if (token_check(rs$title_hdr$right)) {
for (i in seq_len(length(rs$title_hdr$right))) {
if (token_check(rs$title_hdr$right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$title_hdr$right[i], "right")
}
}
}
}
for (cntnt in rs$content) {
if (!is.null(cntnt$object$title_hdr)) {
if (token_check(cntnt$object$title_hdr$right)) {
for (i in seq_len(length(cntnt$object$title_hdr$right))) {
if (token_check(cntnt$object$title_hdr$right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], cntnt$object$title_hdr$right[i], "right")
}
}
}
}
}
}
return(lns)
}
# Write Text Driver Function ----------------------------------------------
#' @title
#' Write a text report to the file system
#'
#' @description
#' This function writes a report_spec object to the file system, using the
#' parameters provided in the object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
write_report_text <- function(rs) {
# Calculate available space for content
rs <- page_setup(rs)
# Get page template for easy access
pt <- rs$page_template
# Put content in new variable for easy access
ls <- rs$content
# Break content into pages
ret <- paginate_content(rs, ls)
# Assign table column widths back to report spec for reference
rs$column_widths <- ret[["widths"]]
# Assign graphics flag back to report spec
rs$has_graphics <- ret[["has_graphics"]]
# Assign pages to ls and continue processing
ls <- ret[["pages"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(ls[[1]]$pages))
ls[[1]]$pages <- ls[[1]]$pages[seq(1, rs$preview)]
}
# Write pages to file
rs <- write_content(rs, ls, pt)
# After report is written, reopen and fix the page numbers.
# Reason is we don't really know how many pages there are
# until the report is written.
rs <- write_page_numbers(rs)
invisible(rs)
}
#' @title Paginate content
#' @description This loop breaks long content into separate pages.
#' @details
#' Tricky part is taking account of a partially filled page with no page break.
#' Basically we need to track how many lines are on the last page,
#' and send to next pagination call to use for an offset.
#' @noRd
paginate_content <- function(rs, ls) {
last_page_lines <- 0
last_object <- FALSE
table_widths <- list()
tmp_dir <- tempdir()
has_graphics <- FALSE
for(i in seq_along(ls)){
if (i == length(ls))
last_object <- TRUE
else
last_object <- FALSE
# Break content into multiple pages if needed.
# If there are multiple pages, each function is responsible for
# filling out the page body entirely. Only the last page will
# remain open, in case there is more content and no page break between.
# Blanks on last page are handled below.
# If a last page is left unfinished, and there is no page break,
# the last_page_lines variable is populated with the number of lines
# on the last page. That is passed to the next function, so it can
# subtract those lines from the first page of the next piece of content.
if (class(ls[[i]]$object)[1] == "table_spec"){
ret <- create_table_pages_text(rs, ls[[i]], last_page_lines)
table_widths[[length(table_widths) + 1]] <- ret[["widths"]]
pgs <- ret[["page_list"]]
} else if (class(ls[[i]]$object)[1] == "text_spec") {
pgs <- create_text_pages_text(rs, ls[[i]], last_page_lines)
} else if (class(ls[[i]]$object)[1] == "plot_spec") {
pgs <- create_plot_pages_text(rs, ls[[i]], last_page_lines, tmp_dir)
has_graphics <- TRUE
}
# Append pages to content page list
# These will be written out in following step
ls[[i]]$pages <- pgs
last_page <- pgs[[length(pgs)]]
last_page_lines <- length(last_page) + last_page_lines
# If there is more than one page returned, then a page break occurred
# and we can reset the last page lines.
if (length(pgs) > 1)
last_page_lines <- length(last_page)
# print(paste("Last page lines:", last_page_lines))
# If there is a requested page break, or it is the last object/last page,
# then fill up the remaining page with blanks.
if (ls[[i]]$page_break | last_object) {
# Fill blanks on last page
blnks <- c()
bl <- rs$body_line_count - last_page_lines
if (bl > 0)
blnks <- rep("", bl)
last_page <- append(last_page, blnks)
last_page_lines <- 0 # Needed for requested page breaks
#print(paste("Last Page Line Count:", length(last_page)))
}
if (ls[[i]]$page_break == TRUE | last_page_lines >= rs$body_line_count)
last_page_lines <- 0
# Replace last page with any modifications
ls[[i]]$pages[[length(pgs)]] <- last_page
}
ret <- list(widths = table_widths, pages = ls, has_graphics = has_graphics)
return(ret)
}
#' @title Write out content
#' @description This loop writes out pages created in paginate_content
#' @noRd
write_content <- function(rs, ls, pt) {
# Kill existing file
if (file.exists(rs$modified_path))
file.remove(rs$modified_path)
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
blank_margin_top <- rep("", rs$blank_margin_top)
blank_margin_left <- paste0(rep(" ", rs$blank_margin_left), collapse = "")
for (cont in ls) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(ls))
last_object <- TRUE
else
last_object <- FALSE
for (pg in cont$pages) {
page <- page + 1
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
f <- file(rs$modified_path, open="a", encoding = "native.enc")
if (rs$blank_margins)
writeLines(enc2utf8(blank_margin_top), con = f, useBytes = TRUE)
#print(page_open)
if (page_open == FALSE) {
if (!is.null(pt$page_header))
writeLines(enc2utf8(paste0(blank_margin_left, pt$page_header)),
con = f, useBytes = TRUE)
if (!is.null(pt$title_hdr)) {
tmp <- trimws(pad_any(pt$title_hdr, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
if (!is.null(pt$titles)) {
tmp <- trimws(pad_any(pt$titles, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
}
if (!is.null(pg)) {
tmp <- trimws(pad_any(pg, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(pt$footnotes)) {
tmp <- trimws(pad_any(pt$footnotes, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
if (!is.null(pt$page_footer))
writeLines(enc2utf8(paste0(blank_margin_left, pt$page_footer)),
con = f, useBytes = TRUE)
# Add form feed character for text page break
if (last_object == FALSE | last_page == FALSE) {
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
writeLines(enc2utf8(""), con = f, sep = "\f", useBytes = TRUE)
}
}
close(f)
}
}
return(rs)
}
#' @description Setup page for content
#' @details Calculates available space for content and prepares text lines
#' for page template.
#' @noRd
page_setup <- function(rs) {
debug <- FALSE
if (debug) {
print(paste("Row height:", rs$row_height))
print(paste("Character width:", rs$char_width))
}
# Content size is the page size minus margins, in units of measure
rs$content_size <- get_content_size(rs)
if (debug)
print(paste0("Content Size: ", rs$content_size))
# Line size is the number of characters that will fit in the content size width
if (is.null(rs$user_line_size)) {
if (rs$output_type == "RTF") {
# 1 char adjustment to avoid occasional wrapping
rs$line_size <- floor(rs$content_size[["width"]] / rs$char_width) - 1
} else {
rs$line_size <- floor(rs$content_size[["width"]] / rs$char_width)
}
} else
rs$line_size <- rs$user_line_size
if (debug)
print(paste0("Line Size: ", rs$line_size))
# Line count is the number of lines that will fit in the content size height
if (is.null(rs$user_line_count))
rs$line_count <- floor(rs$content_size[["height"]] / rs$row_height)
else
rs$line_count <- rs$user_line_count
if (debug)
print(paste0("Line Count: ", rs$line_count))
# Get page template
# Page template is the headers, footers, titles, and footnotes attached to report
# Requires the line_size
# Returns a page_template_text object
pt <- page_template_text(rs)
rs$page_template <- pt
#print(pt)
# Get the page template row count
# Include all the rows associated with the page template
rs$page_template_header_count <- length(pt$page_header) + length(pt$titles) +
length(pt$title_hdr) + length(pt$page_by)
if (debug)
print(paste("Page Template Header Count:", rs$page_template_header_count))
rs$page_template_footer_count <- length(pt$footnotes) + length(pt$page_footer)
if (debug)
print(paste("Page Template Footer Count:", rs$page_template_footer_count))
rs$page_template_row_count <- rs$page_template_header_count +
rs$page_template_footer_count
if (debug)
print(paste("Page Template Row Count:", rs$page_template_row_count))
# Body line count is the number of rows available for content on each page
rs$body_line_count <- rs$line_count - rs$page_template_row_count
if (debug)
print(paste0("Body Line Count: ", rs$body_line_count))
# Calculate blank margins, if specified
if (rs$blank_margins) {
rs$blank_margin_top <- floor((rs$margin_top - rs$min_margin) / rs$row_height)
} else
rs$blank_margin_top <- 0
if (debug)
print(paste("Blank Margin Top:", rs$blank_margin_top))
if (rs$blank_margins)
rs$blank_margin_left <- ceiling((rs$margin_left - rs$min_margin) / rs$char_width)
else
rs$blank_margin_left <- 0
if (debug)
print(paste("Blank Margin Left:", rs$blank_margin_left))
return(rs)
}
#' @description Update page numbers in text file
#' @details Logic is to read in each line of the file, loop through and replace
#' tokens as needed. Pages numbers are incremented every time a form feed
#' is encountered. Total pages is retrieved from the report pages property.
#' Total pages is calculated when a page break occurs.
#' @noRd
write_page_numbers <- function(rs) {
# Read file into vector
lns <- readLines(rs$modified_path, encoding = "UTF-8")
# Adjust page count
rs$pages <- rs$pages + 1
# Set up page variables
tpg <- rs$pages
pg <- 1
# Define vectorized function to replace tokens
replace_tokens <- Vectorize(function(x, srch, just) {
ret <- x
# Update page number if hit a page break
if (grepl("\f", x, fixed = TRUE)) {
#print("Updated page number")
# This double arrow <<- is updating the pg variable in the containing
# function write_page_numbers(). It is not updating the global environment.
pg <<- pg + 1
}
# Replace tokens, but keep overall width the same
if (grepl(srch, x, fixed = TRUE)) {
#print("found it")
tmp <- sub("[tpg]", tpg, srch, fixed = TRUE)
tmp <- sub("[pg]", pg, tmp, fixed = TRUE)
tmp <- pad_any(tmp, nchar(srch), just)
ret <- sub(srch, tmp, x, fixed = TRUE)
}
return(ret)
})
# Call vectorized function on entire page header/footer segment
if (token_check(rs$page_header_left)) {
for (i in seq_len(length(rs$page_header_left))) {
if (token_check(rs$page_header_left[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_header_left[i], "left")
}
}
}
if (token_check(rs$page_header_right)) {
for (i in seq_len(length(rs$page_header_right))) {
if (token_check(rs$page_header_right[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_header_right[i], "right")
}
}
}
if (token_check(rs$page_footer_left)) {
for (i in seq_len(length(rs$page_footer_left))) {
if (token_check(rs$page_footer_left[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_left[i], "left")
}
}
}
if (token_check(rs$page_footer_center)) {
for (i in seq_len(length(rs$page_footer_center))) {
if (token_check(rs$page_footer_center[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_center[i], "centre")
}
}
}
if (token_check(rs$page_footer_right)) {
for (i in seq_len(length(rs$page_footer_right))) {
if (token_check( rs$page_footer_right[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_right[i], "right")
}
}
}
if (!is.null(rs$title_hdr)) {
for (th in rs$title_hdr) {
if (token_check(th$right)) {
for (i in seq_len(length(th$right))) {
if (token_check(th$right[i])) {
pg <- 1
lns <- replace_tokens(lns, th$right[i], "right")
}
}
}
}
}
for (cntnt in rs$content) {
if (!is.null(cntnt$object$title_hdr)) {
for (th in cntnt$object$title_hdr) {
if (token_check(th$right)) {
for (i in seq_len(length(th$right))) {
if (token_check(th$right[i])) {
pg <- 1
lns <- replace_tokens(lns, th$right[i], "right")
}
}
}
}
}
}
# Replace file with updated lines
f <- file(rs$modified_path, open="w+", encoding = "native.enc")
writeLines(enc2utf8(lns), con = f, useBytes = TRUE)
close(f)
return(rs)
}
#' @noRd
token_check <- function(x) {
ret <- FALSE
if (!is.null(x))
if (any(nchar(x) > 0))
if (any(grepl("[pg]", x, fixed = TRUE)) |
any(grepl("[tpg]", x, fixed = TRUE)))
ret <- TRUE
return(ret)
}
Try the reporter package in your browser
Any scripts or data that you put into this service are public.
reporter documentation built on May 29, 2024, 4:43 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions token_check write_page_numbers page_setup write_content paginate_content write_report_text update_page_numbers create_content create_report_text
# Special Functions for PDF and RTF ---------------------------------------
#' @title
#' Create a text report, but not on the file system
#'
#' @description
#' This function creates a report, using the
#' parameters provided in the report_spec object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
create_report_text <- function(rs) {
# Calculate available space for content
rs <- page_setup(rs)
# Get page template for easy access
pt <- rs$page_template
# Put content in new variable for easy access
ls <- rs$content
# Break content into pages
ret <- paginate_content(rs, ls)
# Assign table column widths back to report spec for reference
rs$column_widths <- ret[["widths"]]
# Assign graphics flag back to report spec
rs$has_graphics <- ret[["has_graphics"]]
# Assign pages to ls and continue processing
ls <- ret[["pages"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(ls[[1]]$pages))
ls[[1]]$pages <- ls[[1]]$pages[seq(1, rs$preview)]
}
# Combine all content pages
res <- create_content(rs, ls, pt)
rs <- res$rs
ls <- res$ls
# After report is created, fix the page numbers.
# Reason is we don't really know how many pages there are
# until the report is created.
upt <- update_page_numbers(rs, ls)
res <- list(rs = rs, ls = upt)
return(res)
}
#' @title Create content for PDF and RTF output type.
#' @description This loop prepares pages created in paginate_content
#' @noRd
create_content <- function(rs, ls, pt) {
ret <- list()
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
blank_margin_top <- rep("", rs$blank_margin_top)
blank_margin_left <- paste0(rep(" ", rs$blank_margin_left), collapse = "")
for (cont in ls) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(ls))
last_object <- TRUE
else
last_object <- FALSE
for (pg in cont$pages) {
page <- page + 1
# Vector to hold lines on a page
if (page_open == FALSE)
lns <- c()
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
if (rs$blank_margins)
lns <- append(lns, blank_margin_top)
#print(page_open)
if (page_open == FALSE) {
if (!is.null(pt$page_header))
lns <- append(lns, paste0(blank_margin_left, pt$page_header))
if (!is.null(pt$title_hdr)) {
tmp <- trimws(pad_any(pt$title_hdr, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
if (!is.null(pt$titles)) {
tmp <- trimws(pad_any(pt$titles, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
}
if (!is.null(pg)) {
tmp <- trimws(pad_any(pg, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(pt$footnotes)) {
tmp <- trimws(pad_any(pt$footnotes, rs$line_size, get_justify(cont$align)),
which = "right")
lns <- append(lns, paste0(blank_margin_left, tmp))
}
if (!is.null(pt$page_footer))
lns <- append(lns, paste0(blank_margin_left, pt$page_footer))
# Increment total page count
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
# If page not open, add to list
ret[[length(ret) + 1]] <- lns
}
}
}
res <- list(rs = rs, ls = ret)
return(res)
}
#' @description Update page numbers in text file
#' @details Logic is to read in each line of the file, loop through and replace
#' tokens as needed. Pages numbers are incremented every time a form feed
#' is encountered. Total pages is retrieved from the report pages property.
#' Total pages is calculated when a page break occurs.
#' @noRd
update_page_numbers <- function(rs, lns) {
# Set up page variables
tpg <- rs$pages
# Define vectorized function to replace tokens
replace_tokens <- Vectorize(function(x, srch, just) {
ret <- x
# Replace tokens, but keep overall width the same
if (grepl(srch, x, fixed = TRUE)) {
#print("found it")
tmp <- sub("[tpg]", tpg, srch, fixed = TRUE)
tmp <- sub("[pg]", pg, tmp, fixed = TRUE)
tmp <- pad_any(tmp, nchar(srch), just)
ret <- sub(srch, tmp, x, fixed = TRUE)
}
return(ret)
}, USE.NAMES = FALSE)
for (pg in seq_along(lns)) {
# Call vectorized function on entire page header/footer segment
if (token_check(rs$page_header_left)) {
for (i in seq_len(length(rs$page_header_left))) {
if (token_check(rs$page_header_left[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_header_left[i], "left")
}
}
}
if (token_check(rs$page_header_right)) {
for (i in seq_len(length(rs$page_header_right))) {
if (token_check(rs$page_header_right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_header_right[i], "right")
}
}
}
if (token_check(rs$page_footer_left)) {
for (i in seq_len(length(rs$page_footer_left))) {
if (token_check(rs$page_footer_left[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_left[i], "left")
}
}
}
if (token_check(rs$page_footer_center)) {
for (i in seq_len(length(rs$page_footer_center))) {
if (token_check(rs$page_footer_center[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_center[i], "centre")
}
}
}
if (token_check(rs$page_footer_right)) {
for (i in seq_len(length(rs$page_footer_right))) {
if (token_check( rs$page_footer_right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$page_footer_right[i], "right")
}
}
}
if (!is.null(rs$title_hdr)) {
if (token_check(rs$title_hdr$right)) {
for (i in seq_len(length(rs$title_hdr$right))) {
if (token_check(rs$title_hdr$right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], rs$title_hdr$right[i], "right")
}
}
}
}
for (cntnt in rs$content) {
if (!is.null(cntnt$object$title_hdr)) {
if (token_check(cntnt$object$title_hdr$right)) {
for (i in seq_len(length(cntnt$object$title_hdr$right))) {
if (token_check(cntnt$object$title_hdr$right[i])) {
lns[[pg]] <- replace_tokens(lns[[pg]], cntnt$object$title_hdr$right[i], "right")
}
}
}
}
}
}
return(lns)
}
# Write Text Driver Function ----------------------------------------------
#' @title
#' Write a text report to the file system
#'
#' @description
#' This function writes a report_spec object to the file system, using the
#' parameters provided in the object.
#'
#' @param x The report_spec object to write.
#' @return The report spec.
#' @noRd
write_report_text <- function(rs) {
# Calculate available space for content
rs <- page_setup(rs)
# Get page template for easy access
pt <- rs$page_template
# Put content in new variable for easy access
ls <- rs$content
# Break content into pages
ret <- paginate_content(rs, ls)
# Assign table column widths back to report spec for reference
rs$column_widths <- ret[["widths"]]
# Assign graphics flag back to report spec
rs$has_graphics <- ret[["has_graphics"]]
# Assign pages to ls and continue processing
ls <- ret[["pages"]]
# Deal with preview
if (!is.null(rs$preview)) {
if (rs$preview < length(ls[[1]]$pages))
ls[[1]]$pages <- ls[[1]]$pages[seq(1, rs$preview)]
}
# Write pages to file
rs <- write_content(rs, ls, pt)
# After report is written, reopen and fix the page numbers.
# Reason is we don't really know how many pages there are
# until the report is written.
rs <- write_page_numbers(rs)
invisible(rs)
}
#' @title Paginate content
#' @description This loop breaks long content into separate pages.
#' @details
#' Tricky part is taking account of a partially filled page with no page break.
#' Basically we need to track how many lines are on the last page,
#' and send to next pagination call to use for an offset.
#' @noRd
paginate_content <- function(rs, ls) {
last_page_lines <- 0
last_object <- FALSE
table_widths <- list()
tmp_dir <- tempdir()
has_graphics <- FALSE
for(i in seq_along(ls)){
if (i == length(ls))
last_object <- TRUE
else
last_object <- FALSE
# Break content into multiple pages if needed.
# If there are multiple pages, each function is responsible for
# filling out the page body entirely. Only the last page will
# remain open, in case there is more content and no page break between.
# Blanks on last page are handled below.
# If a last page is left unfinished, and there is no page break,
# the last_page_lines variable is populated with the number of lines
# on the last page. That is passed to the next function, so it can
# subtract those lines from the first page of the next piece of content.
if (class(ls[[i]]$object)[1] == "table_spec"){
ret <- create_table_pages_text(rs, ls[[i]], last_page_lines)
table_widths[[length(table_widths) + 1]] <- ret[["widths"]]
pgs <- ret[["page_list"]]
} else if (class(ls[[i]]$object)[1] == "text_spec") {
pgs <- create_text_pages_text(rs, ls[[i]], last_page_lines)
} else if (class(ls[[i]]$object)[1] == "plot_spec") {
pgs <- create_plot_pages_text(rs, ls[[i]], last_page_lines, tmp_dir)
has_graphics <- TRUE
}
# Append pages to content page list
# These will be written out in following step
ls[[i]]$pages <- pgs
last_page <- pgs[[length(pgs)]]
last_page_lines <- length(last_page) + last_page_lines
# If there is more than one page returned, then a page break occurred
# and we can reset the last page lines.
if (length(pgs) > 1)
last_page_lines <- length(last_page)
# print(paste("Last page lines:", last_page_lines))
# If there is a requested page break, or it is the last object/last page,
# then fill up the remaining page with blanks.
if (ls[[i]]$page_break | last_object) {
# Fill blanks on last page
blnks <- c()
bl <- rs$body_line_count - last_page_lines
if (bl > 0)
blnks <- rep("", bl)
last_page <- append(last_page, blnks)
last_page_lines <- 0 # Needed for requested page breaks
#print(paste("Last Page Line Count:", length(last_page)))
}
if (ls[[i]]$page_break == TRUE | last_page_lines >= rs$body_line_count)
last_page_lines <- 0
# Replace last page with any modifications
ls[[i]]$pages[[length(pgs)]] <- last_page
}
ret <- list(widths = table_widths, pages = ls, has_graphics = has_graphics)
return(ret)
}
#' @title Write out content
#' @description This loop writes out pages created in paginate_content
#' @noRd
write_content <- function(rs, ls, pt) {
# Kill existing file
if (file.exists(rs$modified_path))
file.remove(rs$modified_path)
counter <- 0
page <- 0
last_object <- FALSE
last_page <- FALSE
page_open <- FALSE
blank_margin_top <- rep("", rs$blank_margin_top)
blank_margin_left <- paste0(rep(" ", rs$blank_margin_left), collapse = "")
for (cont in ls) {
# Increment counter
counter <- counter + 1
page <- 0
# Set last_object flag
if (counter == length(ls))
last_object <- TRUE
else
last_object <- FALSE
for (pg in cont$pages) {
page <- page + 1
if (page == length(cont$pages))
last_page <- TRUE
else
last_page <- FALSE
f <- file(rs$modified_path, open="a", encoding = "native.enc")
if (rs$blank_margins)
writeLines(enc2utf8(blank_margin_top), con = f, useBytes = TRUE)
#print(page_open)
if (page_open == FALSE) {
if (!is.null(pt$page_header))
writeLines(enc2utf8(paste0(blank_margin_left, pt$page_header)),
con = f, useBytes = TRUE)
if (!is.null(pt$title_hdr)) {
tmp <- trimws(pad_any(pt$title_hdr, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
if (!is.null(pt$titles)) {
tmp <- trimws(pad_any(pt$titles, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
}
if (!is.null(pg)) {
tmp <- trimws(pad_any(pg, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
# Set page_open flag based on status of page_break and current objects
if (last_object == FALSE & last_page == TRUE & cont$page_break == FALSE)
page_open <- TRUE
else
page_open <- FALSE
if (page_open == FALSE) {
if (!is.null(pt$footnotes)) {
tmp <- trimws(pad_any(pt$footnotes, rs$line_size, get_justify(cont$align)),
which = "right")
writeLines(enc2utf8(paste0(blank_margin_left, tmp)),
con = f, useBytes = TRUE)
}
if (!is.null(pt$page_footer))
writeLines(enc2utf8(paste0(blank_margin_left, pt$page_footer)),
con = f, useBytes = TRUE)
# Add form feed character for text page break
if (last_object == FALSE | last_page == FALSE) {
if (is.null(rs$pages))
rs$pages <- 1
else
rs$pages <- rs$pages + 1
writeLines(enc2utf8(""), con = f, sep = "\f", useBytes = TRUE)
}
}
close(f)
}
}
return(rs)
}
#' @description Setup page for content
#' @details Calculates available space for content and prepares text lines
#' for page template.
#' @noRd
page_setup <- function(rs) {
debug <- FALSE
if (debug) {
print(paste("Row height:", rs$row_height))
print(paste("Character width:", rs$char_width))
}
# Content size is the page size minus margins, in units of measure
rs$content_size <- get_content_size(rs)
if (debug)
print(paste0("Content Size: ", rs$content_size))
# Line size is the number of characters that will fit in the content size width
if (is.null(rs$user_line_size)) {
if (rs$output_type == "RTF") {
# 1 char adjustment to avoid occasional wrapping
rs$line_size <- floor(rs$content_size[["width"]] / rs$char_width) - 1
} else {
rs$line_size <- floor(rs$content_size[["width"]] / rs$char_width)
}
} else
rs$line_size <- rs$user_line_size
if (debug)
print(paste0("Line Size: ", rs$line_size))
# Line count is the number of lines that will fit in the content size height
if (is.null(rs$user_line_count))
rs$line_count <- floor(rs$content_size[["height"]] / rs$row_height)
else
rs$line_count <- rs$user_line_count
if (debug)
print(paste0("Line Count: ", rs$line_count))
# Get page template
# Page template is the headers, footers, titles, and footnotes attached to report
# Requires the line_size
# Returns a page_template_text object
pt <- page_template_text(rs)
rs$page_template <- pt
#print(pt)
# Get the page template row count
# Include all the rows associated with the page template
rs$page_template_header_count <- length(pt$page_header) + length(pt$titles) +
length(pt$title_hdr) + length(pt$page_by)
if (debug)
print(paste("Page Template Header Count:", rs$page_template_header_count))
rs$page_template_footer_count <- length(pt$footnotes) + length(pt$page_footer)
if (debug)
print(paste("Page Template Footer Count:", rs$page_template_footer_count))
rs$page_template_row_count <- rs$page_template_header_count +
rs$page_template_footer_count
if (debug)
print(paste("Page Template Row Count:", rs$page_template_row_count))
# Body line count is the number of rows available for content on each page
rs$body_line_count <- rs$line_count - rs$page_template_row_count
if (debug)
print(paste0("Body Line Count: ", rs$body_line_count))
# Calculate blank margins, if specified
if (rs$blank_margins) {
rs$blank_margin_top <- floor((rs$margin_top - rs$min_margin) / rs$row_height)
} else
rs$blank_margin_top <- 0
if (debug)
print(paste("Blank Margin Top:", rs$blank_margin_top))
if (rs$blank_margins)
rs$blank_margin_left <- ceiling((rs$margin_left - rs$min_margin) / rs$char_width)
else
rs$blank_margin_left <- 0
if (debug)
print(paste("Blank Margin Left:", rs$blank_margin_left))
return(rs)
}
#' @description Update page numbers in text file
#' @details Logic is to read in each line of the file, loop through and replace
#' tokens as needed. Pages numbers are incremented every time a form feed
#' is encountered. Total pages is retrieved from the report pages property.
#' Total pages is calculated when a page break occurs.
#' @noRd
write_page_numbers <- function(rs) {
# Read file into vector
lns <- readLines(rs$modified_path, encoding = "UTF-8")
# Adjust page count
rs$pages <- rs$pages + 1
# Set up page variables
tpg <- rs$pages
pg <- 1
# Define vectorized function to replace tokens
replace_tokens <- Vectorize(function(x, srch, just) {
ret <- x
# Update page number if hit a page break
if (grepl("\f", x, fixed = TRUE)) {
#print("Updated page number")
# This double arrow <<- is updating the pg variable in the containing
# function write_page_numbers(). It is not updating the global environment.
pg <<- pg + 1
}
# Replace tokens, but keep overall width the same
if (grepl(srch, x, fixed = TRUE)) {
#print("found it")
tmp <- sub("[tpg]", tpg, srch, fixed = TRUE)
tmp <- sub("[pg]", pg, tmp, fixed = TRUE)
tmp <- pad_any(tmp, nchar(srch), just)
ret <- sub(srch, tmp, x, fixed = TRUE)
}
return(ret)
})
# Call vectorized function on entire page header/footer segment
if (token_check(rs$page_header_left)) {
for (i in seq_len(length(rs$page_header_left))) {
if (token_check(rs$page_header_left[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_header_left[i], "left")
}
}
}
if (token_check(rs$page_header_right)) {
for (i in seq_len(length(rs$page_header_right))) {
if (token_check(rs$page_header_right[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_header_right[i], "right")
}
}
}
if (token_check(rs$page_footer_left)) {
for (i in seq_len(length(rs$page_footer_left))) {
if (token_check(rs$page_footer_left[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_left[i], "left")
}
}
}
if (token_check(rs$page_footer_center)) {
for (i in seq_len(length(rs$page_footer_center))) {
if (token_check(rs$page_footer_center[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_center[i], "centre")
}
}
}
if (token_check(rs$page_footer_right)) {
for (i in seq_len(length(rs$page_footer_right))) {
if (token_check( rs$page_footer_right[i])) {
pg <- 1
lns <- replace_tokens(lns, rs$page_footer_right[i], "right")
}
}
}
if (!is.null(rs$title_hdr)) {
for (th in rs$title_hdr) {
if (token_check(th$right)) {
for (i in seq_len(length(th$right))) {
if (token_check(th$right[i])) {
pg <- 1
lns <- replace_tokens(lns, th$right[i], "right")
}
}
}
}
}
for (cntnt in rs$content) {
if (!is.null(cntnt$object$title_hdr)) {
for (th in cntnt$object$title_hdr) {
if (token_check(th$right)) {
for (i in seq_len(length(th$right))) {
if (token_check(th$right[i])) {
pg <- 1
lns <- replace_tokens(lns, th$right[i], "right")
}
}
}
}
}
}
# Replace file with updated lines
f <- file(rs$modified_path, open="w+", encoding = "native.enc")
writeLines(enc2utf8(lns), con = f, useBytes = TRUE)
close(f)
return(rs)
}
#' @noRd
token_check <- function(x) {
ret <- FALSE
if (!is.null(x))
if (any(nchar(x) > 0))
if (any(grepl("[pg]", x, fixed = TRUE)) |
any(grepl("[tpg]", x, fixed = TRUE)))
ret <- TRUE
return(ret)
}
Try the reporter package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.