Nothing
R/page_template_rtf.R
In reporter: Creates Statistical Reports
Defines functions
get_page_numbers_rtf
get_cell_borders
get_page_by_rtf_back
get_page_by_rtf
get_title_header_rtf
get_footnotes_rtf_back
get_footnotes_rtf
get_titles_rtf_back
get_titles_rtf
get_page_footer_rtf
get_page_header_rtf
page_template_rtf
# The page template is everything except the content: page header/footer,
# titles, footnotes, etc.
# Page Template RTF Functions ---------------------------------------------
#' Create a page template with header, titles, footnotes, and footer.
#' @param rs The report spec
#' @return The page template object
#' @noRd
page_template_rtf<- function(rs) {
pt <- structure(list(), class = c("page_template_rtf", "list"))
pt$page_header <- get_page_header_rtf(rs)
pt$title_hdr <- get_title_header_rtf(rs$title_hdr, rs$line_size, rs)
pt$titles <- get_titles_rtf(rs$titles, rs$line_size, rs)
pt$footnotes <- c()
if (!is.null(rs$footnotes)) {
if (!is.null(rs$footnotes[[1]])) {
if (rs$footnotes[[1]]$valign == "bottom")
pt$footnotes <- get_footnotes_rtf(rs$footnotes, rs$line_size, rs)
}
}
pt$page_footer <- get_page_footer_rtf(rs)
pt$lines <- sum(pt$page_header$lines, pt$page_footer$lines,
pt$title_hdr$lines, pt$titles$lines, pt$footnotes$lines)
pt$twips <- sum(pt$page_header$twips, pt$page_footer$twips,
pt$title_hdr$twips, pt$titles$twips, pt$footnotes$twips)
# Page by not here. Messes up line counts.
return(pt)
}
#' @import grDevices
#' @noRd
get_page_header_rtf <- function(rs) {
ret <- ""
cnt <- 0
twps <- 0
hl <- rs$page_header_left
hr <- rs$page_header_right
conv <- rs$twip_conversion
lh <- rs$row_height
# User controlled width of left column
lwdth <- rs$page_header_width
if (is.null(lwdth))
lwdth <- rs$content_size[["width"]]/2
# Calculate right column width
rwdth <- rs$content_size[["width"]] - lwdth
maxh <- max(length(hl), length(hr))
if (maxh > 0 | length(rs$header_titles) > 0) {
fs <- rs$font_size * 2
c1 <- round(lwdth * conv)
c2 <- round(rwdth * conv) + c1
ret <- paste0("{\\header \\f0\\fs", fs)
if (maxh > 0) {
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq(1, maxh)) {
ret <- paste0(ret, "\\trowd\\trgaph0\\trrh", lh,
"\\cellx", c1, "\\cellx", c2)
if (length(hl) >= i) {
# Split strings if they exceed width
tmp <- split_string_rtf(hl[[i]], lwdth, rs$units)
ret <- paste0(ret, "\\ql ", get_page_numbers_rtf(tmp$rtf), "\\cell")
lcnt <- tmp$lines
} else {
ret <- paste0(ret, "\\ql \\cell")
lcnt <- 1
}
if (length(hr) >= i) {
# Split strings if they exceed width
tmp2 <- split_string_rtf(hr[[i]], rwdth, rs$units)
ret <- paste0(ret, "\\qr ", get_page_numbers_rtf(tmp2$rtf), "\\cell\\row\n")
rcnt <- tmp2$lines
} else {
ret <- paste0(ret, "\\qr \\cell\\row\n")
rcnt <- 1
}
if (lcnt > rcnt)
cnt <- cnt + lcnt
else
cnt <- cnt + rcnt
}
dev.off()
if (rs$page_header_blank_row == "below") {
ret <- paste0(ret, "\\par\\pard", rs$font_rtf, rs$spacing_multiplier)
cnt <- cnt + 1
} else {
ret <- paste0(ret, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
}
}
htitles <- ""
if (!is.null(rs$header_titles)) {
tret <- get_titles_rtf(rs$header_titles, rs$content_size[["width"]], rs)
htitles <- paste0(tret$rtf, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
cnt <- cnt + tret$lines
}
ret <- paste0(ret, htitles, "}")
}
twps <- cnt * lh
res <- list(rtf = ret, lines = cnt, twips = twps)
return(res)
}
#' @import grDevices
#' @noRd
get_page_footer_rtf <- function(rs) {
ret <- ""
cnt <- 0
twps <- 0
fl <- rs$page_footer_left
fc <- rs$page_footer_center
fr <- rs$page_footer_right
conv <- rs$twip_conversion
lh <- rs$row_height
maxf <- max(length(fl), length(fc), length(fr))
if (maxf > 0 | length(rs$footer_footnotes) > 0) {
fs <- rs$font_size * 2
c3 <- round(rs$content_size[["width"]] * conv)
c1 <- round(c3 / 3)
c2 <- round(c1 * 2)
ret <- paste0("{\\footer \\f0\\fs", fs, "[ff]")
if (maxf > 0) {
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq(1, maxf)) {
ret <- paste0(ret, "\\trowd\\trgaph0\\cellx", c1,
"\\cellx", c2 , "\\cellx", c3)
if (length(fl) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_rtf(fl[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\ql ", get_page_numbers_rtf(tmp1$rtf), "\\cell")
lcnt <- tmp1$lines
} else {
ret <- paste0(ret, "\\ql \\cell")
lcnt <- 1
}
if (length(fc) >= i) {
# Split strings if they exceed width
tmp2 <- split_string_rtf(fc[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\qc ", get_page_numbers_rtf(tmp2$rtf), "\\cell")
ccnt <- tmp2$lines
} else {
ret <- paste0(ret, "\\qc \\cell")
ccnt <- 1
}
if (length(fr) >= i) {
tmp3 <- split_string_rtf(fr[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\qr ", get_page_numbers_rtf(tmp3$rtf), "\\cell\\row\n")
rcnt <- tmp3$lines
} else {
ret <- paste0(ret, "\\qr \\cell\\row\n")
rcnt <- 1
}
cnt <- cnt + max(lcnt, ccnt, rcnt)
}
dev.off()
}
ffootnotes <- ""
if (!is.null(rs$footer_footnotes)) {
tret <- get_footnotes_rtf(rs$footer_footnotes, rs$content_size[["width"]], rs)
ffootnotes <- paste0(tret$rtf, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
cnt <- cnt + tret$lines
}
ret <- sub("[ff]", ffootnotes, ret, fixed = TRUE)
ret <- paste0(ret, "\\fs1\\sl0\\par\\pard",
rs$font_rtf, rs$spacing_multiplier, "}")
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_rtf <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
conv <- rs$twip_conversion
lh <- rs$row_height
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
cols <- ttls$columns
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width * conv)
cwidth <- width / cols
cw <- round(w / cols)
if (ttls$align == "center")
algn <- "\\qc"
else if (ttls$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
border_flag <- FALSE
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
al <- ""
# Get blank row above
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(1, 1, length(ttls$titles) + alcnt, 1, ttls$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
bl <- ""
# Get blank row below
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(length(ttls$titles) + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
sm <- get_spacing_multiplier(rs$font_size)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, sm, "\\cell\\row\n")
cnt <- cnt + 1
}
# Append blank row above
if (al != "")
ret <- append(ret, al)
fz <- ""
fs <- ""
# Get font size
if (!is.null(ttls$font_size)) {
fz <- paste0("\\fs", ttls$font_size * 2,
get_spacing_multiplier(ttls$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
# Reset column width accumulation
cwa <- 0
# Calculate total number of rows in this block
rws <- ceiling(length(ttls$titles) / cols) + alcnt + blcnt
i <- 1
while (i <= length(ttls$titles)) {
mxlns <- 0
# Calculate current row
rw <- ceiling(i / cols)
# Start row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta))
for (j in seq_len(cols)) {
# Get border specs for this cell
b <- get_cell_borders(rw + alcnt, j,
rws,
cols, ttls$borders)
# Not all cells have titles
if (i > length(ttls$titles))
vl <- ""
else
vl <- ttls$titles[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "\\ql"
else
calgn <- "\\qr"
} else if (cols == 3) {
if (j == 1)
calgn <- "\\ql"
else if (j == 2)
calgn <- "\\qc"
else if (j == 3)
calgn <- "\\qr"
}
if (j == 1)
cwa <- 0
# RTF cell widths are absolute ending points
cwa <- cwa + cw
# Split title strings if they exceed width
tmp <- split_string_rtf(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
# Add bold if needed
tb <- get_page_numbers_rtf(tmp$rtf, FALSE)
if (ttls$bold)
tb <- paste0("\\b ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\b0")
# Construct cell from constituent parts
ret <- append(ret, paste0(b, "\\cellx", cwa,
calgn, fz, " ", tb, fs, "\\cell"))
i <- i + 1
}
# End row
ret <- append(ret, "\\row\n")
# Track lines
cnt <- cnt + mxlns
}
# Append blank row below
if (bl != "")
ret <- append(ret, bl)
if (any(ttls$borders %in% c("outside", "all", "bottom")))
border_flag <- TRUE
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_rtf_back <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
conv <- rs$twip_conversion
lh <- rs$row_height
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width * conv)
if (ttls$align == "center")
algn <- "\\qc"
else if (ttls$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
border_flag <- FALSE
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq_along(ttls$titles)) {
al <- ""
if (i == 1) {
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, length(ttls$titles) + alcnt, 1, ttls$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ttls$titles)) {
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
sm <- get_spacing_multiplier(rs$font_size)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, sm, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ttls$borders %in% c("outside", "all", "bottom")))
border_flag <- TRUE
}
b <- get_cell_borders(i + alcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
# Split title strings if they exceed width
tmp <- split_string_rtf(ttls$titles[[i]], width, rs$units)
fz <- ""
fs <- ""
if (!is.null(ttls$font_size)) {
fz <- paste0("\\fs", ttls$font_size * 2,
get_spacing_multiplier(ttls$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
tb <- tmp$rtf
if (ttls$bold)
tb <- paste0("\\b ", tmp$rtf, "\\b0")
# Concatenate title string
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
algn, fz, " ", tb, fs, "\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_rtf <- function(ftnlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
cols <- ftnts$columns
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width * conv)
cwidth <- width / cols
cw <- round(w / cols)
if (ftnts$align == "center")
algn <- "\\qc"
else if (ftnts$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
al <- ""
# Get blank row above
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(1, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
bl <- ""
# Get blank row below
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(length(ftnts$footnotes) + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ftnts$borders %in% c("outside", "all", "top")))
border_flag <- TRUE
# Append blank row above
if (al != "")
ret <- append(ret, al)
fz <- ""
fs <- ""
# Get font size - Not used yet
if (!is.null(ftnts$font_size)) {
fz <- paste0("\\fs", ftnts$font_size * 2,
get_spacing_multiplier(ftnts$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
# Reset column width accumulation
cwa <- 0
# Calculate total number of rows in this block
rws <- ceiling(length(ftnts$footnotes) / cols) + alcnt + blcnt
i <- 1
while (i <= length(ftnts$footnotes)) {
mxlns <- 0
# Calculate current row
rw <- ceiling(i / cols)
# Start row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta))
for (j in seq_len(cols)) {
# Get border specs for this cell
# b <- get_cell_borders(i + alcnt, 1,
# length(ftnts$footnotes) + alcnt + blcnt,
# 1, ftnts$borders)
b <- get_cell_borders(rw + alcnt, j,
rws,
cols, ftnts$borders)
# Not all cells have titles
if (i > length(ftnts$footnotes))
vl <- ""
else
vl <- ftnts$footnotes[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "\\ql"
else
calgn <- "\\qr"
} else if (cols == 3) {
if (j == 1)
calgn <- "\\ql"
else if (j == 2)
calgn <- "\\qc"
else if (j == 3)
calgn <- "\\qr"
}
if (j == 1)
cwa <- 0
# RTF cell widths are absolute ending points
cwa <- cwa + cw
# Split footnote strings if they exceed width
tmp <- split_string_rtf(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
# Add italics if requested
if (ftnts$italic)
txt <- paste0("\\i ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\i0")
else
txt <- paste0(" ", get_page_numbers_rtf(tmp$rtf, FALSE))
# Concat footnote row
# ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
# algn, txt,
# "\\cell\\row\n"))
# Construct cell from constituent parts
ret <- append(ret, paste0(b, "\\cellx", cwa,
calgn, fz, txt, fs, "\\cell"))
i <- i + 1
}
# End row
ret <- append(ret, "\\row\n")
# Track lines
cnt <- cnt + mxlns
}
if (bl != "")
ret <- append(ret, bl)
# Do I need this?
# if (any(ftnts$borders %in% c("outside", "all", "bottom")))
# border_flag <- TRUE
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_rtf_back <- function(ftnlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width * conv)
if (ftnts$align == "center")
algn <- "\\qc"
else if (ftnts$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq_along(ftnts$footnotes)) {
al <- ""
if (i == 1) {
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ftnts$footnotes)) {
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ftnts$borders %in% c("outside", "all", "top")))
border_flag <- TRUE
}
b <- get_cell_borders(i + alcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
# Split footnote strings if they exceed width
tmp <- split_string_rtf(ftnts$footnotes[[i]], width, rs$units)
if (al != "")
ret <- append(ret, al)
if (ftnts$italic)
txt <- paste0("\\i ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\i0")
else
txt <- paste0(" ", get_page_numbers_rtf(tmp$rtf, FALSE))
# Concat footnote row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
algn, txt,
"\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_title_header_rtf <- function(thdrlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(thdrlst) > 0) {
for (ttlhdr in thdrlst) {
if (ttlhdr$width == "page")
width <- rs$content_size[["width"]]
else if (ttlhdr$width == "content")
width <- content_width
else if (is.numeric(ttlhdr$width))
width <- ttlhdr$width
w1 <- round(width * conv)
w2 <- round(width * .7 * conv)
mx <- max(length(ttlhdr$titles), length(ttlhdr$right))
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for(i in seq_len(mx)) {
al <- ""
if (i == 1) {
if (any(ttlhdr$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, mx + alcnt,
1, ttlhdr$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w1,
"\\ql\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == mx) {
if (any(ttlhdr$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
mx + alcnt + blcnt,
1, ttlhdr$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w1,
"\\ql\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ttlhdr$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
if (length(ttlhdr$titles) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_rtf(ttlhdr$titles[[i]], width * .7, rs$units)
ttl <- tmp1$rtf
tcnt <- tmp1$lines
} else {
ttl <- ""
tcnt <- 1
}
if (length(ttlhdr$right) >= i) {
tmp2 <- split_string_rtf(ttlhdr$right[[i]],
width * .3, rs$units)
hdr <- get_page_numbers_rtf(tmp2$rtf, FALSE)
hcnt <- tmp2$lines
} else {
hdr <- ""
hcnt <- 1
}
b1 <- get_cell_borders(i + alcnt, 1, mx + alcnt + blcnt, 2, ttlhdr$borders)
b2 <- get_cell_borders(i + alcnt, 2, mx+ alcnt + blcnt, 2, ttlhdr$borders)
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b1, "\\cellx", w2,
b2, "\\cellx", w1,
"\\ql ", ttl, "\\cell\\qr ",
hdr, "\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
if (tcnt > hcnt)
cnt <- cnt + tcnt
else
cnt <- cnt + hcnt
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @param titles Page by object
#' @param width The width to set the page by strings to
#' @return A vector of strings
#' @noRd
get_page_by_rtf <- function(pgby, width, value, rs, talgn, pgby_cnt = NULL) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- get_pgby_value(value, pgby_cnt)
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w1 <- round(width * rs$twip_conversion)
algn <- "\\ql"
if (pgby$align == "right")
algn <- "\\qr"
else if (pgby$align %in% c("center", "centre"))
algn <- "\\qc"
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders(1, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
tb <- get_cell_borders(brow, 1 , trows, 1, pgby$borders)
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Account for multiple pgby lines
tmp <- split_string_rtf(value, width, rs$units)
vl <- tmp$rtf
cnt <- cnt + tmp$lines
dev.off()
# Construct RTF for pageby value
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn, " ",
pgby$label, vl, "\\cell\\row\n")
# cnt <- cnt + get_lines_rtf(paste0( pgby$label, ": ", value), width,
# rs$font, rs$font_size, rs$units)
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders(trows, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
if (any(pgby$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * rs$line_height,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @param titles Page by object
#' @param width The width to set the page by strings to
#' @return A vector of strings
#' @noRd
get_page_by_rtf_back <- function(pgby, width, value, rs, talgn) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- ""
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w1 <- round(width * rs$twip_conversion)
algn <- "\\ql"
if (pgby$align == "right")
algn <- "\\qr"
else if (pgby$align %in% c("center", "centre"))
algn <- "\\qc"
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders(1, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
tb <- get_cell_borders(brow, 1 , trows, 1, pgby$borders)
#tmp <- split_string_rtf(vl, cwidth, rs$units)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn, " ",
pgby$label, value, "\\cell\\row\n")
cnt <- cnt + get_lines_rtf(paste0( pgby$label, ": ", value), width,
rs$font, rs$font_size, rs$units)
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders(trows, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
if (any(pgby$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * rs$line_height,
border_flag = border_flag)
return(res)
}
# Utilities ---------------------------------------------------------------
get_cell_borders <- function(row, col, nrow, ncol, brdrs, flag = "", exclude = NULL) {
t <- ""
b <- ""
l <- ""
r <- ""
if ("all" %in% brdrs) {
t <- "\\clbrdrt\\brdrs"
b <- "\\clbrdrb\\brdrs"
l <- "\\clbrdrl\\brdrs"
r <- "\\clbrdrr\\brdrs"
} else {
if ("inside" %in% brdrs) {
t <- "\\clbrdrt\\brdrs"
b <- "\\clbrdrb\\brdrs"
l <- "\\clbrdrl\\brdrs"
r <- "\\clbrdrr\\brdrs"
if (col == 1)
l <- ""
if (col == ncol)
r <- ""
if (row == nrow)
b <- ""
if (row == 1)
t <- ""
}
if (row == 1 & any(brdrs %in% c("outside", "top")))
t <- "\\clbrdrt\\brdrs"
if (row == nrow & any(brdrs %in% c("bottom", "outside")))
b <- "\\clbrdrb\\brdrs"
if (col == 1 & any(brdrs %in% c("outside", "left")))
l <- "\\clbrdrl\\brdrs"
if (col == ncol & any(brdrs %in% c("outside", "right")))
r <- "\\clbrdrr\\brdrs"
}
# Deal with flag
if (!is.na(flag)) {
if (flag %in% c("L", "B")) {
if (col == 1 & any(brdrs %in% c("outside", "right", "all")))
r <- "\\clbrdrr\\brdrs"
if (col != 1)
l <- ""
}
}
if (!is.null(exclude)) {
if (any(exclude == "top"))
t <- ""
if (any(exclude == "bottom"))
b <- ""
if (any(exclude == "left"))
l <- ""
if (any(exclude == "right"))
r <- ""
}
ret <- paste0(t, b, l, r)
return(ret)
}
get_page_numbers_rtf <- function(val, tpg = TRUE) {
ret <- val
ret <- gsub("[pg]", "\\chpgn ", ret, fixed = TRUE)
if (tpg)
ret <- gsub("[tpg]", "{\\field{\\*\\fldinst NUMPAGES }}", ret, fixed = 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 get_page_numbers_rtf get_cell_borders get_page_by_rtf_back get_page_by_rtf get_title_header_rtf get_footnotes_rtf_back get_footnotes_rtf get_titles_rtf_back get_titles_rtf get_page_footer_rtf get_page_header_rtf page_template_rtf
# The page template is everything except the content: page header/footer,
# titles, footnotes, etc.
# Page Template RTF Functions ---------------------------------------------
#' Create a page template with header, titles, footnotes, and footer.
#' @param rs The report spec
#' @return The page template object
#' @noRd
page_template_rtf<- function(rs) {
pt <- structure(list(), class = c("page_template_rtf", "list"))
pt$page_header <- get_page_header_rtf(rs)
pt$title_hdr <- get_title_header_rtf(rs$title_hdr, rs$line_size, rs)
pt$titles <- get_titles_rtf(rs$titles, rs$line_size, rs)
pt$footnotes <- c()
if (!is.null(rs$footnotes)) {
if (!is.null(rs$footnotes[[1]])) {
if (rs$footnotes[[1]]$valign == "bottom")
pt$footnotes <- get_footnotes_rtf(rs$footnotes, rs$line_size, rs)
}
}
pt$page_footer <- get_page_footer_rtf(rs)
pt$lines <- sum(pt$page_header$lines, pt$page_footer$lines,
pt$title_hdr$lines, pt$titles$lines, pt$footnotes$lines)
pt$twips <- sum(pt$page_header$twips, pt$page_footer$twips,
pt$title_hdr$twips, pt$titles$twips, pt$footnotes$twips)
# Page by not here. Messes up line counts.
return(pt)
}
#' @import grDevices
#' @noRd
get_page_header_rtf <- function(rs) {
ret <- ""
cnt <- 0
twps <- 0
hl <- rs$page_header_left
hr <- rs$page_header_right
conv <- rs$twip_conversion
lh <- rs$row_height
# User controlled width of left column
lwdth <- rs$page_header_width
if (is.null(lwdth))
lwdth <- rs$content_size[["width"]]/2
# Calculate right column width
rwdth <- rs$content_size[["width"]] - lwdth
maxh <- max(length(hl), length(hr))
if (maxh > 0 | length(rs$header_titles) > 0) {
fs <- rs$font_size * 2
c1 <- round(lwdth * conv)
c2 <- round(rwdth * conv) + c1
ret <- paste0("{\\header \\f0\\fs", fs)
if (maxh > 0) {
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq(1, maxh)) {
ret <- paste0(ret, "\\trowd\\trgaph0\\trrh", lh,
"\\cellx", c1, "\\cellx", c2)
if (length(hl) >= i) {
# Split strings if they exceed width
tmp <- split_string_rtf(hl[[i]], lwdth, rs$units)
ret <- paste0(ret, "\\ql ", get_page_numbers_rtf(tmp$rtf), "\\cell")
lcnt <- tmp$lines
} else {
ret <- paste0(ret, "\\ql \\cell")
lcnt <- 1
}
if (length(hr) >= i) {
# Split strings if they exceed width
tmp2 <- split_string_rtf(hr[[i]], rwdth, rs$units)
ret <- paste0(ret, "\\qr ", get_page_numbers_rtf(tmp2$rtf), "\\cell\\row\n")
rcnt <- tmp2$lines
} else {
ret <- paste0(ret, "\\qr \\cell\\row\n")
rcnt <- 1
}
if (lcnt > rcnt)
cnt <- cnt + lcnt
else
cnt <- cnt + rcnt
}
dev.off()
if (rs$page_header_blank_row == "below") {
ret <- paste0(ret, "\\par\\pard", rs$font_rtf, rs$spacing_multiplier)
cnt <- cnt + 1
} else {
ret <- paste0(ret, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
}
}
htitles <- ""
if (!is.null(rs$header_titles)) {
tret <- get_titles_rtf(rs$header_titles, rs$content_size[["width"]], rs)
htitles <- paste0(tret$rtf, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
cnt <- cnt + tret$lines
}
ret <- paste0(ret, htitles, "}")
}
twps <- cnt * lh
res <- list(rtf = ret, lines = cnt, twips = twps)
return(res)
}
#' @import grDevices
#' @noRd
get_page_footer_rtf <- function(rs) {
ret <- ""
cnt <- 0
twps <- 0
fl <- rs$page_footer_left
fc <- rs$page_footer_center
fr <- rs$page_footer_right
conv <- rs$twip_conversion
lh <- rs$row_height
maxf <- max(length(fl), length(fc), length(fr))
if (maxf > 0 | length(rs$footer_footnotes) > 0) {
fs <- rs$font_size * 2
c3 <- round(rs$content_size[["width"]] * conv)
c1 <- round(c3 / 3)
c2 <- round(c1 * 2)
ret <- paste0("{\\footer \\f0\\fs", fs, "[ff]")
if (maxf > 0) {
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq(1, maxf)) {
ret <- paste0(ret, "\\trowd\\trgaph0\\cellx", c1,
"\\cellx", c2 , "\\cellx", c3)
if (length(fl) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_rtf(fl[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\ql ", get_page_numbers_rtf(tmp1$rtf), "\\cell")
lcnt <- tmp1$lines
} else {
ret <- paste0(ret, "\\ql \\cell")
lcnt <- 1
}
if (length(fc) >= i) {
# Split strings if they exceed width
tmp2 <- split_string_rtf(fc[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\qc ", get_page_numbers_rtf(tmp2$rtf), "\\cell")
ccnt <- tmp2$lines
} else {
ret <- paste0(ret, "\\qc \\cell")
ccnt <- 1
}
if (length(fr) >= i) {
tmp3 <- split_string_rtf(fr[[i]], rs$content_size[["width"]]/3, rs$units)
ret <- paste0(ret, "\\qr ", get_page_numbers_rtf(tmp3$rtf), "\\cell\\row\n")
rcnt <- tmp3$lines
} else {
ret <- paste0(ret, "\\qr \\cell\\row\n")
rcnt <- 1
}
cnt <- cnt + max(lcnt, ccnt, rcnt)
}
dev.off()
}
ffootnotes <- ""
if (!is.null(rs$footer_footnotes)) {
tret <- get_footnotes_rtf(rs$footer_footnotes, rs$content_size[["width"]], rs)
ffootnotes <- paste0(tret$rtf, "\\fs1\\sl0\\par\\pard", rs$font_rtf,
rs$spacing_multiplier)
cnt <- cnt + tret$lines
}
ret <- sub("[ff]", ffootnotes, ret, fixed = TRUE)
ret <- paste0(ret, "\\fs1\\sl0\\par\\pard",
rs$font_rtf, rs$spacing_multiplier, "}")
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_rtf <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
conv <- rs$twip_conversion
lh <- rs$row_height
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
cols <- ttls$columns
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width * conv)
cwidth <- width / cols
cw <- round(w / cols)
if (ttls$align == "center")
algn <- "\\qc"
else if (ttls$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
border_flag <- FALSE
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
al <- ""
# Get blank row above
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(1, 1, length(ttls$titles) + alcnt, 1, ttls$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
bl <- ""
# Get blank row below
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(length(ttls$titles) + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
sm <- get_spacing_multiplier(rs$font_size)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, sm, "\\cell\\row\n")
cnt <- cnt + 1
}
# Append blank row above
if (al != "")
ret <- append(ret, al)
fz <- ""
fs <- ""
# Get font size
if (!is.null(ttls$font_size)) {
fz <- paste0("\\fs", ttls$font_size * 2,
get_spacing_multiplier(ttls$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
# Reset column width accumulation
cwa <- 0
# Calculate total number of rows in this block
rws <- ceiling(length(ttls$titles) / cols) + alcnt + blcnt
i <- 1
while (i <= length(ttls$titles)) {
mxlns <- 0
# Calculate current row
rw <- ceiling(i / cols)
# Start row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta))
for (j in seq_len(cols)) {
# Get border specs for this cell
b <- get_cell_borders(rw + alcnt, j,
rws,
cols, ttls$borders)
# Not all cells have titles
if (i > length(ttls$titles))
vl <- ""
else
vl <- ttls$titles[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "\\ql"
else
calgn <- "\\qr"
} else if (cols == 3) {
if (j == 1)
calgn <- "\\ql"
else if (j == 2)
calgn <- "\\qc"
else if (j == 3)
calgn <- "\\qr"
}
if (j == 1)
cwa <- 0
# RTF cell widths are absolute ending points
cwa <- cwa + cw
# Split title strings if they exceed width
tmp <- split_string_rtf(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
# Add bold if needed
tb <- get_page_numbers_rtf(tmp$rtf, FALSE)
if (ttls$bold)
tb <- paste0("\\b ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\b0")
# Construct cell from constituent parts
ret <- append(ret, paste0(b, "\\cellx", cwa,
calgn, fz, " ", tb, fs, "\\cell"))
i <- i + 1
}
# End row
ret <- append(ret, "\\row\n")
# Track lines
cnt <- cnt + mxlns
}
# Append blank row below
if (bl != "")
ret <- append(ret, bl)
if (any(ttls$borders %in% c("outside", "all", "bottom")))
border_flag <- TRUE
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_titles_rtf_back <- function(ttllst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
conv <- rs$twip_conversion
lh <- rs$row_height
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ttllst) > 0) {
for (ttls in ttllst) {
if (ttls$width == "page")
width <- rs$content_size[["width"]]
else if (ttls$width == "content")
width <- content_width
else if (is.numeric(ttls$width))
width <- ttls$width
w <- round(width * conv)
if (ttls$align == "center")
algn <- "\\qc"
else if (ttls$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
border_flag <- FALSE
alcnt <- 0
blcnt <- 0
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq_along(ttls$titles)) {
al <- ""
if (i == 1) {
if (any(ttls$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, length(ttls$titles) + alcnt, 1, ttls$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ttls$titles)) {
if (any(ttls$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
sm <- get_spacing_multiplier(rs$font_size)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, sm, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ttls$borders %in% c("outside", "all", "bottom")))
border_flag <- TRUE
}
b <- get_cell_borders(i + alcnt, 1,
length(ttls$titles) + alcnt + blcnt,
1, ttls$borders)
# Split title strings if they exceed width
tmp <- split_string_rtf(ttls$titles[[i]], width, rs$units)
fz <- ""
fs <- ""
if (!is.null(ttls$font_size)) {
fz <- paste0("\\fs", ttls$font_size * 2,
get_spacing_multiplier(ttls$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
tb <- tmp$rtf
if (ttls$bold)
tb <- paste0("\\b ", tmp$rtf, "\\b0")
# Concatenate title string
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
algn, fz, " ", tb, fs, "\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_rtf <- function(ftnlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
cols <- ftnts$columns
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width * conv)
cwidth <- width / cols
cw <- round(w / cols)
if (ftnts$align == "center")
algn <- "\\qc"
else if (ftnts$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
al <- ""
# Get blank row above
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(1, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
bl <- ""
# Get blank row below
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(length(ftnts$footnotes) + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ftnts$borders %in% c("outside", "all", "top")))
border_flag <- TRUE
# Append blank row above
if (al != "")
ret <- append(ret, al)
fz <- ""
fs <- ""
# Get font size - Not used yet
if (!is.null(ftnts$font_size)) {
fz <- paste0("\\fs", ftnts$font_size * 2,
get_spacing_multiplier(ftnts$font_size))
fs <- paste0("\\fs", rs$font_size * 2)
}
# Reset column width accumulation
cwa <- 0
# Calculate total number of rows in this block
rws <- ceiling(length(ftnts$footnotes) / cols) + alcnt + blcnt
i <- 1
while (i <= length(ftnts$footnotes)) {
mxlns <- 0
# Calculate current row
rw <- ceiling(i / cols)
# Start row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta))
for (j in seq_len(cols)) {
# Get border specs for this cell
# b <- get_cell_borders(i + alcnt, 1,
# length(ftnts$footnotes) + alcnt + blcnt,
# 1, ftnts$borders)
b <- get_cell_borders(rw + alcnt, j,
rws,
cols, ftnts$borders)
# Not all cells have titles
if (i > length(ftnts$footnotes))
vl <- ""
else
vl <- ftnts$footnotes[[i]]
# Deal with column alignments
if (cols == 1) {
calgn <- algn
} else if (cols == 2) {
if (j == 1)
calgn <- "\\ql"
else
calgn <- "\\qr"
} else if (cols == 3) {
if (j == 1)
calgn <- "\\ql"
else if (j == 2)
calgn <- "\\qc"
else if (j == 3)
calgn <- "\\qr"
}
if (j == 1)
cwa <- 0
# RTF cell widths are absolute ending points
cwa <- cwa + cw
# Split footnote strings if they exceed width
tmp <- split_string_rtf(vl, cwidth, rs$units)
# Track max lines for counting
if (tmp$lines > mxlns)
mxlns <- tmp$lines
# Add italics if requested
if (ftnts$italic)
txt <- paste0("\\i ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\i0")
else
txt <- paste0(" ", get_page_numbers_rtf(tmp$rtf, FALSE))
# Concat footnote row
# ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
# algn, txt,
# "\\cell\\row\n"))
# Construct cell from constituent parts
ret <- append(ret, paste0(b, "\\cellx", cwa,
calgn, fz, txt, fs, "\\cell"))
i <- i + 1
}
# End row
ret <- append(ret, "\\row\n")
# Track lines
cnt <- cnt + mxlns
}
if (bl != "")
ret <- append(ret, bl)
# Do I need this?
# if (any(ftnts$borders %in% c("outside", "all", "bottom")))
# border_flag <- TRUE
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_footnotes_rtf_back <- function(ftnlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(ftnlst) > 0) {
for (ftnts in ftnlst) {
if (ftnts$width == "page")
width <- rs$content_size[["width"]]
else if (ftnts$width == "content")
width <- content_width
else if (is.numeric(ftnts$width))
width <- ftnts$width
w <- round(width * conv)
if (ftnts$align == "center")
algn <- "\\qc"
else if (ftnts$align == "right")
algn <- "\\qr"
else
algn <- "\\ql"
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for (i in seq_along(ftnts$footnotes)) {
al <- ""
if (i == 1) {
if (any(ftnts$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, length(ftnts$footnotes) + alcnt,
1, ftnts$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == length(ftnts$footnotes)) {
if (any(ftnts$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w,
algn, "\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ftnts$borders %in% c("outside", "all", "top")))
border_flag <- TRUE
}
b <- get_cell_borders(i + alcnt, 1,
length(ftnts$footnotes) + alcnt + blcnt,
1, ftnts$borders)
# Split footnote strings if they exceed width
tmp <- split_string_rtf(ftnts$footnotes[[i]], width, rs$units)
if (al != "")
ret <- append(ret, al)
if (ftnts$italic)
txt <- paste0("\\i ", get_page_numbers_rtf(tmp$rtf, FALSE), "\\i0")
else
txt <- paste0(" ", get_page_numbers_rtf(tmp$rtf, FALSE))
# Concat footnote row
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b, "\\cellx", w,
algn, txt,
"\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
cnt <- cnt + tmp$lines
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' @import grDevices
#' @noRd
get_title_header_rtf <- function(thdrlst, content_width, rs, talgn = "center") {
ret <- c()
cnt <- 0
twps <- 0
border_flag <- FALSE
conv <- rs$twip_conversion
lh <- rs$row_height
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (length(thdrlst) > 0) {
for (ttlhdr in thdrlst) {
if (ttlhdr$width == "page")
width <- rs$content_size[["width"]]
else if (ttlhdr$width == "content")
width <- content_width
else if (is.numeric(ttlhdr$width))
width <- ttlhdr$width
w1 <- round(width * conv)
w2 <- round(width * .7 * conv)
mx <- max(length(ttlhdr$titles), length(ttlhdr$right))
alcnt <- 0
blcnt <- 0
border_flag <- FALSE
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for(i in seq_len(mx)) {
al <- ""
if (i == 1) {
if (any(ttlhdr$blank_row %in% c("above", "both"))) {
alcnt <- 1
tb <- get_cell_borders(i, 1, mx + alcnt,
1, ttlhdr$borders)
al <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w1,
"\\ql\\cell\\row\n")
cnt <- cnt + 1
}
}
bl <- ""
if (i == mx) {
if (any(ttlhdr$blank_row %in% c("below", "both"))) {
blcnt <- 1
tb <- get_cell_borders(i + alcnt + blcnt, 1,
mx + alcnt + blcnt,
1, ttlhdr$borders)
bl <- paste0("\\trowd\\trgaph0", ta, tb, "\\cellx", w1,
"\\ql\\cell\\row\n")
cnt <- cnt + 1
}
if (any(ttlhdr$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
if (length(ttlhdr$titles) >= i) {
# Split strings if they exceed width
tmp1 <- split_string_rtf(ttlhdr$titles[[i]], width * .7, rs$units)
ttl <- tmp1$rtf
tcnt <- tmp1$lines
} else {
ttl <- ""
tcnt <- 1
}
if (length(ttlhdr$right) >= i) {
tmp2 <- split_string_rtf(ttlhdr$right[[i]],
width * .3, rs$units)
hdr <- get_page_numbers_rtf(tmp2$rtf, FALSE)
hcnt <- tmp2$lines
} else {
hdr <- ""
hcnt <- 1
}
b1 <- get_cell_borders(i + alcnt, 1, mx + alcnt + blcnt, 2, ttlhdr$borders)
b2 <- get_cell_borders(i + alcnt, 2, mx+ alcnt + blcnt, 2, ttlhdr$borders)
if (al != "")
ret <- append(ret, al)
ret <- append(ret, paste0("\\trowd\\trgaph0", ta, b1, "\\cellx", w2,
b2, "\\cellx", w1,
"\\ql ", ttl, "\\cell\\qr ",
hdr, "\\cell\\row\n"))
if (bl != "")
ret <- append(ret, bl)
if (tcnt > hcnt)
cnt <- cnt + tcnt
else
cnt <- cnt + hcnt
}
dev.off()
}
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * lh,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @param titles Page by object
#' @param width The width to set the page by strings to
#' @return A vector of strings
#' @noRd
get_page_by_rtf <- function(pgby, width, value, rs, talgn, pgby_cnt = NULL) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- get_pgby_value(value, pgby_cnt)
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w1 <- round(width * rs$twip_conversion)
algn <- "\\ql"
if (pgby$align == "right")
algn <- "\\qr"
else if (pgby$align %in% c("center", "centre"))
algn <- "\\qc"
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders(1, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
tb <- get_cell_borders(brow, 1 , trows, 1, pgby$borders)
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Account for multiple pgby lines
tmp <- split_string_rtf(value, width, rs$units)
vl <- tmp$rtf
cnt <- cnt + tmp$lines
dev.off()
# Construct RTF for pageby value
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn, " ",
pgby$label, vl, "\\cell\\row\n")
# cnt <- cnt + get_lines_rtf(paste0( pgby$label, ": ", value), width,
# rs$font, rs$font_size, rs$units)
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders(trows, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
if (any(pgby$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * rs$line_height,
border_flag = border_flag)
return(res)
}
#' Get page by text strings suitable for printing
#' @import stringi
#' @param titles Page by object
#' @param width The width to set the page by strings to
#' @return A vector of strings
#' @noRd
get_page_by_rtf_back <- function(pgby, width, value, rs, talgn) {
if (is.null(width)) {
stop("width cannot be null.")
}
if (is.null(value))
value <- ""
ll <- width
ret <- c()
cnt <- 0
border_flag <- FALSE
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
if (!is.null(pgby)) {
if (!any(class(pgby) == "page_by"))
stop("pgby parameter value is not a page_by.")
w1 <- round(width * rs$twip_conversion)
algn <- "\\ql"
if (pgby$align == "right")
algn <- "\\qr"
else if (pgby$align %in% c("center", "centre"))
algn <- "\\qc"
trows <- 1
brow <- 1
if (pgby$blank_row %in% c("above", "both")) {
trows <- trows + 1
brow <- 2
}
if (pgby$blank_row %in% c("below", "both"))
trows <- trows + 1
if (pgby$blank_row %in% c("above", "both")) {
tb <- get_cell_borders(1, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
tb <- get_cell_borders(brow, 1 , trows, 1, pgby$borders)
#tmp <- split_string_rtf(vl, cwidth, rs$units)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn, " ",
pgby$label, value, "\\cell\\row\n")
cnt <- cnt + get_lines_rtf(paste0( pgby$label, ": ", value), width,
rs$font, rs$font_size, rs$units)
if (pgby$blank_row %in% c("below", "both")) {
tb <- get_cell_borders(trows, 1, trows, 1, pgby$borders)
ret[length(ret) + 1] <- paste0("\\trowd\\trgaph0", ta, tb,
"\\cellx", w1, algn,
"\\cell\\row\n")
cnt <- cnt + 1
}
if (any(pgby$borders %in% c("all", "outside", "bottom")))
border_flag <- TRUE
}
res <- list(rtf = paste0(ret, collapse = ""),
lines = cnt,
twips = cnt * rs$line_height,
border_flag = border_flag)
return(res)
}
# Utilities ---------------------------------------------------------------
get_cell_borders <- function(row, col, nrow, ncol, brdrs, flag = "", exclude = NULL) {
t <- ""
b <- ""
l <- ""
r <- ""
if ("all" %in% brdrs) {
t <- "\\clbrdrt\\brdrs"
b <- "\\clbrdrb\\brdrs"
l <- "\\clbrdrl\\brdrs"
r <- "\\clbrdrr\\brdrs"
} else {
if ("inside" %in% brdrs) {
t <- "\\clbrdrt\\brdrs"
b <- "\\clbrdrb\\brdrs"
l <- "\\clbrdrl\\brdrs"
r <- "\\clbrdrr\\brdrs"
if (col == 1)
l <- ""
if (col == ncol)
r <- ""
if (row == nrow)
b <- ""
if (row == 1)
t <- ""
}
if (row == 1 & any(brdrs %in% c("outside", "top")))
t <- "\\clbrdrt\\brdrs"
if (row == nrow & any(brdrs %in% c("bottom", "outside")))
b <- "\\clbrdrb\\brdrs"
if (col == 1 & any(brdrs %in% c("outside", "left")))
l <- "\\clbrdrl\\brdrs"
if (col == ncol & any(brdrs %in% c("outside", "right")))
r <- "\\clbrdrr\\brdrs"
}
# Deal with flag
if (!is.na(flag)) {
if (flag %in% c("L", "B")) {
if (col == 1 & any(brdrs %in% c("outside", "right", "all")))
r <- "\\clbrdrr\\brdrs"
if (col != 1)
l <- ""
}
}
if (!is.null(exclude)) {
if (any(exclude == "top"))
t <- ""
if (any(exclude == "bottom"))
b <- ""
if (any(exclude == "left"))
l <- ""
if (any(exclude == "right"))
r <- ""
}
ret <- paste0(t, b, l, r)
return(ret)
}
get_page_numbers_rtf <- function(val, tpg = TRUE) {
ret <- val
ret <- gsub("[pg]", "\\chpgn ", ret, fixed = TRUE)
if (tpg)
ret <- gsub("[tpg]", "{\\field{\\*\\fldinst NUMPAGES }}", ret, fixed = 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.