Nothing
R/create_table_rtf.R
In reporter: Creates Statistical Reports
Defines functions
footnotes_aligned
titles_aligned
get_table_body_rtf
get_spanning_header_rtf
get_table_header_rtf
get_content_offsets_rtf
get_page_footnotes_rtf
create_table_rtf
create_table_pages_rtf
# Create Tables ----------------------------------------------------------
#' @noRd
create_table_pages_rtf <- function(rs, cntnt, lpg_rows) {
ts <- cntnt$object
content_blank_row <- cntnt$blank_row
pgby_var <- NA
pgby_cnt <- 0
pgby_fmt <- NULL
if (!is.null(rs$page_by)) {
pgby_var <- rs$page_by$var
pgby_fmt <- rs$page_by$format
} else if (!is.null(ts$page_by)) {
pgby_var <- ts$page_by$var
pgby_fmt <- ts$page_by$format
}
if (all(ts$show_cols == "none") & length(ts$col_defs) == 0) {
stop("ERROR: At least one column must be defined if show_cols = \"none\".")
}
font_name <- rs$font
# Set up control columns
dat <- as.data.frame(ts$data, stringsAsFactors = FALSE)
dat$..blank <- ""
dat$..row <- 1
dat$..page_by <- NA
# If page_break variable has been defined, use it
if (is.null(ts$page_var)) {
if (is.na(pgby_var))
dat$..page <- NA
else
dat$..page <- dat[[pgby_var]]
} else {
if (any(class(dat[[ts$page_var]]) == "factor"))
dat$..page <- as.character(dat[[ts$page_var]])
else
dat$..page <- dat[[ts$page_var]]
}
# If page by is defined, use it
if (!is.na(pgby_var)) {
# Clear out factors on page by if they exist
# Needed because split cells used to convert everything to characters
if (any(class(dat[[pgby_var]]) == "factor")) {
dat[[pgby_var]] <- as.character(dat[[pgby_var]] )
dat$..page_by <- dat[[pgby_var]]
if (any(class(dat$..page) == "factor"))
dat$..page <- as.character(dat[[pgby_var]])
} else {
if (!is.null(pgby_fmt))
dat$..page_by <- fapply(dat[[pgby_var]], pgby_fmt)
else
dat$..page_by <- dat[[pgby_var]]
}
pgby_cnt <- get_pgby_cnt(dat$..page_by)
# Commenting out for now
# if (is.unsorted(dat[[pgby_var]], strictly = FALSE))
# message("Page by variable not sorted.")
}
# Deal with invisible columns
if (!is.null(ts$col_defs)) {
for (def in ts$col_defs) {
if (def$visible == FALSE) {
nnm <- paste0("..x.", def$var_c)
dat[[nnm]] <- dat[[def$var_c]]
}
}
}
# Get control column names
control_cols <- names(dat)[is.controlv(names(dat))]
# Get vector of all included column names
# Not all columns in dataset are necessarily included
# depends on show_cols parameter on create_table and
# visible parameter on column definitions
keys <- get_table_cols(ts, control_cols)
# print("keys")
# print(keys)
# Filter dataset by included columns
dat <- get_data_subset(dat, keys, rs$preview)
# print("Key columns:")
# print(dat)
# Update column definitions with column defaults
ts$col_defs <- set_column_defaults(ts, keys)
# print("col_defs:")
# print(ts$col_defs)
# Deal with styles
styles <- get_styles(ts)
# Get labels
labels <- get_labels(dat, ts)
# print("Labels:")
# print(labels)
# Get column alignments
aligns <- get_aligns(dat, ts)
# Get alignment for labels
# Follows column alignment by default
label_aligns <- get_label_aligns(ts, aligns)
# print("Label Aligns:")
# print(label_aligns)
# Clear out existing formats
cdat <- clear_formats(dat)
# Get column formats
formats(cdat) <- get_col_formats(dat, ts)
# print("formats:")
# print(formats(cdat))
# Apply formatting
fdat <- fdata(cdat)
# print("fdata:")
# print(fdat)
# Prep data for blank lines, indents, and stub columns
fdat <- prep_data(fdat, ts, rs$char_width, rs$missing) # OK
# print("prep_data")
# print(fdat)
# str(fdat)
# Reset keys, since prep_data can add/remove columns for stub
keys <- names(fdat)
# print("Keys")
# print(keys)
# print("Aligns")
# print(aligns)
# Copy any width attributes to formatted data frame
if ("width" %in% ts$use_attributes)
widths(fdat) <- widths(dat)
# print("Original Widths")
# print(widths(dat))
# Get column widths
widths_uom <- get_col_widths_variable(fdat, ts, labels,
rs$font, rs$font_size, rs$units,
rs$gutter_width)
# print("Widths UOM")
# print(widths_uom)
# Split long text strings into multiple rows. Number of rows are stored in
# ..row variable. If too slow, may need to be rewritten in C
fdat <- split_cells_variable(fdat, widths_uom, rs$font,
rs$font_size, rs$units, rs$output_type, rs$char_width)$data
# print("split_cells")
# print(fdat)
# Break columns into pages
wraps <- get_page_wraps(rs$line_size, ts,
widths_uom, 0, control_cols) # No gutter width for RTF
# print("wraps")
# print(wraps)
# Create a temporary page info to pass into get_content_offsets
tmp_pi <- list(keys = keys, col_width = widths_uom, label = labels,
label_align = label_aligns, table_align = cntnt$align)
# print("Temp PI")
# print(tmp_pi)
# Offsets are needed to calculate splits and page breaks
content_offset <- get_content_offsets_rtf(rs, ts, tmp_pi,
content_blank_row, pgby_cnt)
# split rows
splits <- get_splits_text(fdat, widths_uom, rs$body_line_count,
lpg_rows, content_offset$lines, ts, TRUE)
# print("splits")
# print(splits)
# Subset splits by preview, if requested
if (!is.null(rs$preview)) {
if (rs$preview < length(splits))
splits <- splits[seq(1, rs$preview)]
}
tot_count <- length(splits) * length(wraps)
counter <- 0
wrap_flag <- FALSE
blnk_ind <- "none"
pg_lst <- list()
for(s in splits) {
for(pg in wraps) {
counter <- counter + 1
if (counter < tot_count)
wrap_flag <- TRUE
else
wrap_flag <- FALSE
#print(s)
# Ensure content blank rows are added only to the first and last pages
blnk_ind <- get_blank_indicator(counter, tot_count, content_blank_row,
rs$body_line_count, content_offset$lines,
nrow(s))
#print(blnk_ind)
if (!is.na(pgby_var))
pgby <- trimws(s[1, "..page_by"])
else
pgby <- NULL
pgind <- ""
if (counter == 1)
pgind <- "first"
if (counter == tot_count)
pgind[length(pgind) + 1] <- "last"
# Get page info for this page
pi <- page_info(data= s[, pg], keys = pg, label=labels[pg],
col_width = widths_uom[pg], col_align = aligns[pg],
font_name = font_name, label_align = label_aligns[pg],
pgby, cntnt$align)
# Get rtf for this page
pg_lst[[length(pg_lst) + 1]] <- create_table_rtf(rs, ts, pi,
blnk_ind, wrap_flag,
lpg_rows, pgind, styles)
}
}
ret <- list(widths = widths_uom, page_list = pg_lst)
return(ret)
}
#' @noRd
create_table_rtf <- function(rs, ts, pi, content_blank_row, wrap_flag,
lpg_rows, pgind, styles) {
rh <- rs$row_height
shdrs <- list(lines = 0, twips = 0)
hdrs <- list(lines = 0, twips = 0)
if (ts$headerless == FALSE) {
shdrs <- get_spanning_header_rtf(rs, ts, pi)
hdrs <- get_table_header_rtf(rs, ts, pi$col_width,
pi$label, pi$label_align, pi$table_align)
}
# rs, ts, widths, algns, halgns, talgn
rws <- get_table_body_rtf(rs, pi$data, pi$col_width,
pi$col_align, pi$table_align, ts$borders,
ts$first_row_blank, ts$continuous, styles, pgind)
# Default to content width
ls <- rs$content_size[["width"]]
# Get table width
if (!is.null(pi$col_width))
ls <- sum(pi$col_width, na.rm = TRUE)
if (!is.null(ts$title_hdr))
ttls <- get_title_header_rtf(ts$title_hdr, ls, rs, pi$table_align)
else
ttls <- get_titles_rtf(ts$titles, ls, rs, pi$table_align)
if (!is.null(rs$page_by)) {
pgby <- get_page_by_rtf(rs$page_by, rs$content_size[["width"]],
pi$page_by, rs, pi$table_align)
} else if(!is.null(ts$page_by))
pgby <- get_page_by_rtf(ts$page_by, ls, pi$page_by, rs, pi$table_align)
else
pgby <- c()
a <- NULL
if (content_blank_row %in% c("above", "both"))
a <- paste0("\\par", a)
blnks <- c()
# Get row count by summing ..row variable
# if ("..row" %in% names(pi$data)) {
# rcnt <- sum(pi$data$..row)
# } else {
# rcnt <- nrow(pi$data)
# }
# Determine sum of all lines
rc <- sum(ttls$lines, pgby$lines, shdrs$lines,
hdrs$lines, rws$lines,
length(a))
# Get footnotes, passing in sum of all current lines
ftnts <- get_page_footnotes_rtf(rs, ts, ls, lpg_rows, rc,
wrap_flag, content_blank_row, pi$table_align)
# Deal with cell padding. Don't count this in line count.
cp <- paste0("\\li", rs$cell_padding, "\\ri", rs$cell_padding, rs$spacing_multiplier)
# On LibreOffice, have to protect the table from the title width or
# the table row will inherit the title row width. Terrible problem.
tpt <- "{\\pard\\fs1\\sl0\\par}"
if (any(ts$borders %in% c("all", "top", "outside"))) {
if (ttls$border_flag | rs$page_template$titles$border_flag |
rs$page_template$title_hdr$border_flag)
tpt <- ""
if (length(pgby) > 0) {
if (pgby$border_flag)
tpt <- ""
}
}
if (titles_aligned(ts$titles, ts$title_hdr))
tpt <- ""
# Same thing as above with titles. If footnote block is contiguous
# with table and footnotes are wider than table, row width of footnotes
# will infect row width of table. On libre only. So this is to protect
# the table width.
bpt <- "{\\pard\\fs1\\sl0\\par}"
if (any(ts$borders %in% c("all", "top", "outside", "body"))) {
if (!is.null(ftnts)) {
if (ftnts$border_flag)
bpt <- ""
}
if (!is.null(rs$page_template$footnotes)) {
if (rs$page_template$footnotes$border_flag)
bpt <- ""
}
}
if (footnotes_aligned(ts$footnotes))
bpt <- ""
# Continuous tables are different
# Titles only on first page and footnotes only on last page
if (ts$continuous) {
if ("first" %in% pgind & "last" %in% pgind) {
ret <- list(rtf = c(a, cp, ttls$rtf, pgby$rtf, shdrs$rtf,
hdrs$rtf, rws$rtf, ftnts$rtf),
lines = rc + ftnts$lines)
} else if ("first" %in% pgind) {
ret <- list(rtf = c(a, cp, ttls$rtf, pgby$rtf, shdrs$rtf,
hdrs$rtf, rws$rtf),
lines = rc )
} else if ("last" %in% pgind) {
ret <- list(rtf = c(pgby$rtf,
rws$rtf, ftnts$rtf),
lines = rc + ftnts$lines - ttls$lines)
} else {
ret <- list(rtf = c( pgby$rtf,
rws$rtf),
lines = rc - ttls$lines)
}
} else {
# By default, repeat titles and footnotes on every page
ret <- list(rtf = c(a, cp, ttls$rtf, cp, pgby$rtf, tpt, cp, shdrs$rtf,
hdrs$rtf, rws$rtf, bpt, cp, ftnts$rtf),
lines = rc + ftnts$lines)
}
return(ret)
}
get_page_footnotes_rtf <- function(rs, spec, spec_width, lpg_rows, row_count,
wrap_flag, content_blank_row, talgn) {
ftnts <- list(lines = 0, twips = 0, border_flag = FALSE)
vflag <- "none"
# Deal with valign parameter
if (!is.null(spec$footnotes)) {
if (!is.null(spec$footnotes[[length(spec$footnotes)]])) {
if (spec$footnotes[[length(spec$footnotes)]]$valign == "bottom") {
vflag <- "bottom"
ftnts <- get_footnotes_rtf(spec$footnotes,
spec_width, rs,
talgn)
} else {
vflag <- "top"
ftnts <- get_footnotes_rtf(spec$footnotes, spec_width, rs, talgn)
}
}
} else {
if (!is.null(rs$footnotes[[1]])) {
if (!is.null(rs$footnotes[[1]]$valign)) {
if (rs$footnotes[[1]]$valign == "top") {
vflag <- "top"
ftnts <- get_footnotes_rtf(rs$footnotes,
spec_width, rs,
talgn)
} else {
if (wrap_flag)
vflag <- "bottom"
}
}
}
}
b <- NULL
blen <- 0
if (content_blank_row %in% c("below", "both")) {
b <- "\\par"
blen <- 1
}
# } else {
# b <- paste0("\\fs1\\sl0\\par\\pard", rs$font_rtf, rs$spacing_multiplier)
# }
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
boff <- 0
if (any(class(spec) == "table_spec") &
any(spec$borders %in% c("all", "inside"))) {
boff <- round(row_count * rs$border_height / rs$row_height)
}
ublnks <- c()
lblnks <- c()
# Determine number of filler lines needed
len_diff <- rs$body_line_count - row_count - ftnts$lines - lpg_rows - blen - boff
if (vflag == "bottom" & len_diff > 0) {
ublnks <- c(b, rep("\\par", len_diff))
} else {
if ((wrap_flag & len_diff > 0)) {
if (vflag == "bottom" | has_bottom_footnotes(rs))
lblnks <- c(rep("\\par", len_diff), b)
} else {
lblnks <- b
}
}
tlns <- sum(ftnts$lines, length(ublnks), length(lblnks))
ret <- list(rtf = c(ublnks, ftnts$rtf, lblnks),
lines = tlns,
twips = tlns * rs$twip_conversion,
border_flag = ftnts$border_flag)
return(ret)
}
# Sub-Functions ---------------------------------------------------------
#' Get content offsets for table header, titles, footnotes, and content blanks.
#' Needed to calculate page breaks accurately.
#' @return A vector of upper and lower offsets
#' @noRd
get_content_offsets_rtf <- function(rs, ts, pi, content_blank_row, pgby_cnt = NULL) {
ret <- c(upper = 0, lower = 0, blank_upper = 0, blank_lower = 0)
cnt <- c(upper = 0, lower = 0, blank_upper = 0, blank_lower = 0)
# Width is normally the width of the table, not the page
wdth <- rs$content_size[["width"]]
if (!is.null(pi$col_width))
wdth <- sum(pi$col_width)
# Default to zero
shdrs <- list(lines = 0, twips = 0)
hdrs <- list(lines = 0, twips = 0)
if (ts$headerless == FALSE) {
shdrs <- get_spanning_header_rtf(rs, ts, pi)
hdrs <- get_table_header_rtf(rs, ts, pi$col_width,
pi$label, pi$label_align,
pi$table_align)
}
# Get title headers or titles
if (is.null(ts$title_hdr))
ttls <- get_titles_rtf(ts$titles, wdth, rs)
else
ttls <- get_title_header_rtf(ts$title_hdr, wdth, rs)
# Get page by if it exists
pgb <- list(lines = 0, twips = 0)
if (!is.null(ts$page_by))
pgb <- get_page_by_rtf(ts$page_by, wdth, NULL, rs, pi$table_align, pgby_cnt)
else if (!is.null(rs$page_by))
pgb <- get_page_by_rtf(rs$page_by, wdth, NULL, rs, pi$table_align, pgby_cnt)
#print(length(pgb))
# print(paste("Table titles:", ttls))
# Add everything up
ret[["upper"]] <- shdrs$twips + hdrs$twips + ttls$twips + pgb$twips
cnt[["upper"]] <- shdrs$lines + hdrs$lines + ttls$lines + pgb$lines
if (content_blank_row %in% c("above", "both")) {
ret[["blank_upper"]] <- rs$line_height
cnt[["blank_upper"]] <- 1
}
ftnts <- get_footnotes_rtf(ts$footnotes, wdth, rs)
rftnts <- get_footnotes_rtf(rs$footnotes, wdth, rs)
if (has_top_footnotes(rs)) {
ret[["lower"]] <- ftnts$twips + rftnts$twips
cnt[["lower"]] <- ftnts$lines + rftnts$lines
} else {
ret[["lower"]] <- ftnts$twips
cnt[["lower"]] <- ftnts$lines
}
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
if (any(ts$borders %in% c("all", "inside"))) {
ret[["lower"]] <- ret[["lower"]] + (rs$row_height * 2)
cnt[["lower"]] <- cnt[["lower"]] + 2
}
if (content_blank_row %in% c("both", "below")) {
ret[["blank_lower"]] <- rs$line_height
cnt[["blank_lower"]] <- 1
}
res <- list(lines = cnt,
twips = ret)
return(res)
}
#' @description Return a vector of strings for the table header
#' @details Basic idea of this function is to create a list
#' of string vectors of label words sized according to the column
#' widths, then combine by line/row, and concatenate everything and justify.
#' @noRd
get_table_header_rtf <- function(rs, ts, widths, lbls, halgns, talgn) {
ret <- c()
cnt <- 0
rh <- rs$row_height
tbl <- ts$data
conv <- rs$twip_conversion
nms <- names(lbls)
nms <- nms[!is.controlv(nms)]
# Get cell widths
sz <- c()
for (k in seq_along(widths)) {
if (!is.control(nms[k])) {
if (k == 1)
sz[k] <- round(widths[k] * conv)
else
sz[k] <- round(widths[k] * conv + sz[k - 1])
}
}
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
brdrs <- ts$borders
if (length(ts$col_spans) > 0) {
if (any(ts$borders %in% c("outside")))
brdrs <- c("left", "right")
if (any(ts$borders %in% "top"))
brdrs <- brdrs[!brdrs %in% "top"]
}
# Header Cell alignment
ha <- c()
for (k in seq_along(halgns)) {
if (!is.control(nms[k])) {
if (halgns[k] == "left")
ha[k] <- "\\ql"
else if (halgns[k] == "right")
ha[k] <- "\\qr"
else if (halgns[k] %in% c("center", "centre"))
ha[k] <- "\\qc"
}
}
# Table Header
# Request from Astellas
# Need to watch this for undesired side effects.
if (ts$continuous)
ret[1] <- paste0("\\trowd\\trkeep\\trhdr\\trgaph0", ta, "\\trrh", rh)
else
ret[1] <- paste0("\\trowd\\trgaph0", ta, "\\trrh", rh)
# Loop for cell definitions
for(j in seq_along(nms)) {
if (!is.control(nms[j])) {
b <- get_cell_borders(1, j, 2, length(nms), brdrs)
ret[1] <- paste0(ret[1], "\\clvertalb", b, "\\clbrdrb\\brdrs\\cellx", sz[j])
}
}
cnt <- 1
# Loop for column names
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for(k in seq_along(nms)) {
if (!is.control(nms[k])) {
# Split label strings if they exceed column width
tmp <- split_string_rtf(lbls[k], widths[k], rs$units, rs$font)
tb <- tmp$rtf
if (ts$header_bold)
tb <- paste0("\\b ", tmp$rtf, "\\b0")
ret[1] <- paste0(ret[1], ha[k], " ", tb, "\\cell")
# Add in extra lines for labels that wrap
xtr <- tmp$lines
if (xtr > cnt)
cnt <- xtr
}
}
dev.off()
ret[1] <- paste(ret[1], "\\row")
if (ts$first_row_blank == TRUE) {
if (any(brdrs == "body"))
b <- get_cell_borders(1, 1, 3, 1, c("left", "right"))
else
b <- get_cell_borders(1, 1, 3, 1, brdrs)
w <- round(sum(widths, na.rm = TRUE) * conv)
ret[1] <- paste0(ret[1], "\n\\trowd\\trgaph0", ta,
"\\trrh", rh, b, "\\cellx", w,
"\\ql\\cell\\row")
cnt <- cnt + 1
}
res <- list(rtf = ret,
lines = cnt,
twips = cnt * rh)
return(res)
}
# Need to fix this
#' @description Return a vector of rtf strings for the table spanning headers
#' @details Basic idea of this function is to figure out which columns
#' the header spans, add widths, then call get_table_header. Everything
#' from there is the same.
#' @import stats
#' @noRd
get_spanning_header_rtf <- function(rs, ts, pi) {
spns <- ts$col_spans
cols <- pi$keys
cols <- cols[!is.controlv(cols)]
w <- pi$col_width
w <- w[cols]
gutter <- 0
cnt <- c()
# print("Cols:")
# print(cols)
#print(w)
wlvl <- get_spanning_info(rs, ts, pi, w, gutter)
lvls <- sort(seq_along(wlvl), decreasing = TRUE)
# At this point we have a data frame with labels, etc. and spanning
# column widths, and are ready to create spanning header rows
#print(wlvl)
conv <- rs$twip_conversion
talgn <- pi$table_align
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
# Get borders
brdrs <- ts$borders
if (any(ts$borders %in% "bottom"))
brdrs <- brdrs[!brdrs %in% "bottom"]
rh <- rs$row_height
# Format labels for each level
ln <- c()
for (l in lvls) {
s <- wlvl[[l]]
widths <- s$width
names(widths) <- s$name
algns <- s$align
names(algns) <- s$name
lbls <- s$label
names(lbls) <- s$name
cs <- s$col_span
# Get cell widths
sz <- c()
for (k in seq_along(widths)) {
if (k == 1)
sz[k] <- round(widths[k] * conv)
else
sz[k] <- round(widths[k] * conv + sz[k - 1])
}
# Header Cell alignment
ha <- c()
for (k in seq_along(algns)) {
if (algns[k] == "right")
ha[k] <- "\\qr"
else if (algns[k] %in% c("center", "centre"))
ha[k] <- "\\qc"
else
ha[k] <- "\\ql"
}
r <- ""
cnt[length(cnt) + 1] <- 1
# Table Header
r <- paste0("\\trowd\\trgaph0", ta, "\\trrh", rh)
# Label justification, width, and row concatenation
# Loop for cell definitions
for(j in seq_along(sz)) {
# Get cell borders
b <- get_cell_borders(length(wlvl) - l + 1, j, 10, nrow(s), brdrs)
# Add colspans
vl <- lbls[j]
# Special handling of borders for different situations.
# I hate this, but can't see a way around it.
if (any(brdrs %in% c("all", "inside"))) {
sflg <- "B"
if (j > 1) {
if (cs[j] > 1)
sflg <- ""
}
if (vl == "") {
bb <- get_cell_borders(length(lvls) - l + 1, j, length(lvls),
length(sz), brdrs,
flag = sflg)
} else
bb <- b
} else if (all(brdrs == "outside")) {
if (vl == "")
bb <- b
else {
bb <- b #paste0(b, "\\clbrdrb\\brdrs")
}
} else {
if (vl == "") {
bb <- get_cell_borders(length(lvls) - l + 1, j, length(lvls),
length(sz), brdrs,
flag = "")
} else
bb <- b #paste0(b, "\\clbrdrb\\brdrs")
}
if (s$span[j] > 0 & s$underline[j])
r <- paste0(r, "\\clvertalb", bb, "\\clbrdrb\\brdrs\\cellx", sz[j])
else
r <- paste0(r, "\\clvertalb", bb, "\\cellx", sz[j])
}
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Loop for labels
for(k in seq_along(lbls)) {
# Split label strings if they exceed column width
tmp <- split_string_rtf(lbls[k], widths[k], rs$units, rs$font)
if (s$bold[k])
tb <- paste0("\\b ", tmp$rtf, "\\b0")
else
tb <- paste0(" ", tmp$rtf)
# Concat label
r <- paste0(r, ha[k], tb, "\\cell")
# print(lbls[k])
# print(widths[k])
# Add in extra lines for labels that wrap
xtr <- tmp$lines
if (xtr > cnt[length(cnt)])
cnt[length(cnt)] <- xtr
}
dev.off()
r <- paste0(r, "\\row")
ln[[length(ln) + 1]] <- r
}
ret <- unlist(ln)
res <- list(rtf = ret,
lines = sum(cnt),
twips = sum(cnt) * rh)
return(res)
}
#' @description This function counts lines per row independently because
#' the ..row field does not account for page wrapping. Need number
#' of lines on this particular page.
#' @noRd
get_table_body_rtf <- function(rs, tbl, widths, algns, talgn, tbrdrs,
frb, continuous = FALSE, styles, pgind) {
if ("..blank" %in% names(tbl))
flgs <- tbl$..blank
else
flgs <- NA
# Count lines per row
rws <- c()
nms <- names(widths)
nms <- nms[!is.na(nms)]
nms <- nms[!is.controlv(nms)]
wdths <- widths[nms]
if (length(nms) == 1) {
t <- as.data.frame(tbl[[nms]])
names(t) <- nms
} else
t <- tbl[ , nms]
brdrs <- tbrdrs
if (all(tbrdrs == "body"))
brdrs <- c("top", "bottom", "left", "right")
# Deal with outside borders on continuous tables
if (continuous & "outside" %in% brdrs) {
if ("first" %in% pgind & !"last" %in% pgind) {
brdrs <- c("top", "left", "right")
} else if (!"first" %in% pgind & "last" %in% pgind) {
brdrs <- c("bottom", "left", "right")
} else if (!"first" %in% pgind & !"last" %in% pgind) {
brdrs <- c("left", "right")
}
}
# Get line height. Don't want to leave editor default.
rh <- rs$row_height
conv <- rs$twip_conversion
# Get cell widths
sz <- c()
for (k in seq_along(wdths)) {
if (!is.control(nms[k])) {
if (k == 1)
sz[k] <- round(wdths[k] * conv)
else
sz[k] <- round(wdths[k] * conv + sz[k - 1])
}
}
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
# Cell alignment
ca <- c()
for (k in seq_along(algns)) {
if (!is.control(nms[k])) {
if (algns[k] == "left")
ca[k] <- "\\ql"
else if (algns[k] == "right")
ca[k] <- "\\qr"
else if (algns[k] %in% c("center", "centre"))
ca[k] <- "\\qc"
}
}
ret <- c()
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Table Body
for(i in seq_len(nrow(t))) {
if (i == 1 & continuous == FALSE)
ret[i] <- paste0("{\\trowd\\trgaph0\\trrh", rh, ta)
else
ret[i] <- paste0("\\trowd\\trgaph0\\trrh", rh, ta)
if (flgs[i] %in% c("B", "L")) {
# Deal with blank and label rows
radj <- 0
if (frb == TRUE)
radj <- 1
b <- get_cell_borders(i + radj, 1, nrow(t) + radj, ncol(t), brdrs, flgs[i])
ret[i] <- paste0(ret[i], b, "\\cellx", max(sz))
} else {
# Loop for cell definitions
for(j in seq_len(ncol(t))) {
if (!is.control(nms[j])) {
radj <- 0
if (frb == TRUE)
radj <- 1
b <- get_cell_borders(i + radj, j, nrow(t) + radj, ncol(t), brdrs, flgs[i])
ret[i] <- paste0(ret[i], b, "\\cellx", sz[j])
}
}
}
mxrw <- 1
if (flgs[i] %in% c("B", "L")) {
# Deal with label rows
vl <- t[i, 1]
# Deal with styles
# if (nms[1] %in% names(styles)) {
# stl <- styles[[nms[1]]]
# if (stl$bold == TRUE) {
# bflg <- FALSE
# if (!is.null(stl$indicator)) {
# if ("labelrow" %in% stl$indicator) {
# if (flgs[i] %in% c("L"))
# bflg <- TRUE
# }
# if (stl$indicator %in% names(tbl)) {
# if (!is.null(tbl[[i, stl$indicator]] )) {
# if (tbl[[i, stl$indicator]] == TRUE) {
# bflg <- TRUE
# }
# }
# }
# } else {
# bflg <- TRUE
# }
# if (bflg) {
# vl <- paste0("\\b ", vl, "\\b0")
# }
# }
# }
stl <- get_cell_styles(nms[1], styles, flgs, i, tbl)
if ("bold" %in% stl) {
vl <- paste0("\\b ", vl, "\\b0")
}
ret[i] <- paste0(ret[i], ca[1], " ", vl, "\\cell")
cl <- strsplit(vl, "\\line", fixed = TRUE)[[1]]
if (length(cl) > mxrw)
mxrw <- length(cl)
} else {
# Loop for cell values
for(j in seq_len(ncol(t))) {
if (!is.control(nms[j])) {
tb <- t[i, j]
# if (nms[j] %in% names(styles)) {
# stl <- styles[[nms[j]]]
# if (stl$bold == TRUE) {
# bflg <- TRUE
# if (!is.null(stl$indicator)) {
# if ("datarow" %in% stl$indicator) {
# if (flgs[i] %in% c("B", "L"))
# bflg <- FALSE
#
# } else {
# bflg <- FALSE
# if (stl$indicator %in% names(tbl)) {
# if (!is.null(tbl[[i, stl$indicator]] )) {
# if (tbl[[i, stl$indicator]] == TRUE) {
# bflg <- TRUE
# }
# }
# }
#
# }
# }
# if (bflg) {
# tb <- paste0("\\b ", tb, "\\b0")
# }
# }
# }
stl <- get_cell_styles(nms[j], styles, flgs, i, tbl)
if ("bold" %in% stl) {
tb <- paste0("\\b ", tb, "\\b0")
}
# Construct rtf
ret[i] <- paste0(ret[i], ca[j], " ", tb, "\\cell")
vl <- t[i, j]
if (all(class(vl) != "character"))
vl <- as.character(vl)
# Count lines in cell
cl <- strsplit(vl, "\\line", fixed = TRUE)[[1]]
if (length(cl) > mxrw)
mxrw <- length(cl)
}
}
}
rws[i] <- mxrw
ret[i] <- paste0(ret[i], "\\row")
}
dev.off()
if (!continuous) {
ret[length(ret)] <- paste0(ret[length(ret)], "}\\pard",
rs$font_rtf, rs$spacing_multiplier)
} else {
ret[length(ret)] <- paste0(ret[length(ret)], "") # Not needed
}
res <- list(rtf = ret,
lines = sum(rws))
return(res)
}
# Utility Functions -------------------------------------------------------
titles_aligned <- function(ttls = NULL, ttlhdrs = NULL) {
lst <- ttlhdrs
if (!is.null(ttls))
lst <- ttls
ret <- FALSE
if (!is.null(lst)) {
lastttl <- lst[[length(lst)]]
if (lastttl$width == "content")
ret <- TRUE
}
return(ret)
}
footnotes_aligned <- function(ftnts = NULL) {
lst <- ftnts
ret <- FALSE
if (!is.null(lst)) {
lastfnt <- lst[[1]]
if (lastfnt$width == "content" & lastfnt$valign == "top")
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 footnotes_aligned titles_aligned get_table_body_rtf get_spanning_header_rtf get_table_header_rtf get_content_offsets_rtf get_page_footnotes_rtf create_table_rtf create_table_pages_rtf
# Create Tables ----------------------------------------------------------
#' @noRd
create_table_pages_rtf <- function(rs, cntnt, lpg_rows) {
ts <- cntnt$object
content_blank_row <- cntnt$blank_row
pgby_var <- NA
pgby_cnt <- 0
pgby_fmt <- NULL
if (!is.null(rs$page_by)) {
pgby_var <- rs$page_by$var
pgby_fmt <- rs$page_by$format
} else if (!is.null(ts$page_by)) {
pgby_var <- ts$page_by$var
pgby_fmt <- ts$page_by$format
}
if (all(ts$show_cols == "none") & length(ts$col_defs) == 0) {
stop("ERROR: At least one column must be defined if show_cols = \"none\".")
}
font_name <- rs$font
# Set up control columns
dat <- as.data.frame(ts$data, stringsAsFactors = FALSE)
dat$..blank <- ""
dat$..row <- 1
dat$..page_by <- NA
# If page_break variable has been defined, use it
if (is.null(ts$page_var)) {
if (is.na(pgby_var))
dat$..page <- NA
else
dat$..page <- dat[[pgby_var]]
} else {
if (any(class(dat[[ts$page_var]]) == "factor"))
dat$..page <- as.character(dat[[ts$page_var]])
else
dat$..page <- dat[[ts$page_var]]
}
# If page by is defined, use it
if (!is.na(pgby_var)) {
# Clear out factors on page by if they exist
# Needed because split cells used to convert everything to characters
if (any(class(dat[[pgby_var]]) == "factor")) {
dat[[pgby_var]] <- as.character(dat[[pgby_var]] )
dat$..page_by <- dat[[pgby_var]]
if (any(class(dat$..page) == "factor"))
dat$..page <- as.character(dat[[pgby_var]])
} else {
if (!is.null(pgby_fmt))
dat$..page_by <- fapply(dat[[pgby_var]], pgby_fmt)
else
dat$..page_by <- dat[[pgby_var]]
}
pgby_cnt <- get_pgby_cnt(dat$..page_by)
# Commenting out for now
# if (is.unsorted(dat[[pgby_var]], strictly = FALSE))
# message("Page by variable not sorted.")
}
# Deal with invisible columns
if (!is.null(ts$col_defs)) {
for (def in ts$col_defs) {
if (def$visible == FALSE) {
nnm <- paste0("..x.", def$var_c)
dat[[nnm]] <- dat[[def$var_c]]
}
}
}
# Get control column names
control_cols <- names(dat)[is.controlv(names(dat))]
# Get vector of all included column names
# Not all columns in dataset are necessarily included
# depends on show_cols parameter on create_table and
# visible parameter on column definitions
keys <- get_table_cols(ts, control_cols)
# print("keys")
# print(keys)
# Filter dataset by included columns
dat <- get_data_subset(dat, keys, rs$preview)
# print("Key columns:")
# print(dat)
# Update column definitions with column defaults
ts$col_defs <- set_column_defaults(ts, keys)
# print("col_defs:")
# print(ts$col_defs)
# Deal with styles
styles <- get_styles(ts)
# Get labels
labels <- get_labels(dat, ts)
# print("Labels:")
# print(labels)
# Get column alignments
aligns <- get_aligns(dat, ts)
# Get alignment for labels
# Follows column alignment by default
label_aligns <- get_label_aligns(ts, aligns)
# print("Label Aligns:")
# print(label_aligns)
# Clear out existing formats
cdat <- clear_formats(dat)
# Get column formats
formats(cdat) <- get_col_formats(dat, ts)
# print("formats:")
# print(formats(cdat))
# Apply formatting
fdat <- fdata(cdat)
# print("fdata:")
# print(fdat)
# Prep data for blank lines, indents, and stub columns
fdat <- prep_data(fdat, ts, rs$char_width, rs$missing) # OK
# print("prep_data")
# print(fdat)
# str(fdat)
# Reset keys, since prep_data can add/remove columns for stub
keys <- names(fdat)
# print("Keys")
# print(keys)
# print("Aligns")
# print(aligns)
# Copy any width attributes to formatted data frame
if ("width" %in% ts$use_attributes)
widths(fdat) <- widths(dat)
# print("Original Widths")
# print(widths(dat))
# Get column widths
widths_uom <- get_col_widths_variable(fdat, ts, labels,
rs$font, rs$font_size, rs$units,
rs$gutter_width)
# print("Widths UOM")
# print(widths_uom)
# Split long text strings into multiple rows. Number of rows are stored in
# ..row variable. If too slow, may need to be rewritten in C
fdat <- split_cells_variable(fdat, widths_uom, rs$font,
rs$font_size, rs$units, rs$output_type, rs$char_width)$data
# print("split_cells")
# print(fdat)
# Break columns into pages
wraps <- get_page_wraps(rs$line_size, ts,
widths_uom, 0, control_cols) # No gutter width for RTF
# print("wraps")
# print(wraps)
# Create a temporary page info to pass into get_content_offsets
tmp_pi <- list(keys = keys, col_width = widths_uom, label = labels,
label_align = label_aligns, table_align = cntnt$align)
# print("Temp PI")
# print(tmp_pi)
# Offsets are needed to calculate splits and page breaks
content_offset <- get_content_offsets_rtf(rs, ts, tmp_pi,
content_blank_row, pgby_cnt)
# split rows
splits <- get_splits_text(fdat, widths_uom, rs$body_line_count,
lpg_rows, content_offset$lines, ts, TRUE)
# print("splits")
# print(splits)
# Subset splits by preview, if requested
if (!is.null(rs$preview)) {
if (rs$preview < length(splits))
splits <- splits[seq(1, rs$preview)]
}
tot_count <- length(splits) * length(wraps)
counter <- 0
wrap_flag <- FALSE
blnk_ind <- "none"
pg_lst <- list()
for(s in splits) {
for(pg in wraps) {
counter <- counter + 1
if (counter < tot_count)
wrap_flag <- TRUE
else
wrap_flag <- FALSE
#print(s)
# Ensure content blank rows are added only to the first and last pages
blnk_ind <- get_blank_indicator(counter, tot_count, content_blank_row,
rs$body_line_count, content_offset$lines,
nrow(s))
#print(blnk_ind)
if (!is.na(pgby_var))
pgby <- trimws(s[1, "..page_by"])
else
pgby <- NULL
pgind <- ""
if (counter == 1)
pgind <- "first"
if (counter == tot_count)
pgind[length(pgind) + 1] <- "last"
# Get page info for this page
pi <- page_info(data= s[, pg], keys = pg, label=labels[pg],
col_width = widths_uom[pg], col_align = aligns[pg],
font_name = font_name, label_align = label_aligns[pg],
pgby, cntnt$align)
# Get rtf for this page
pg_lst[[length(pg_lst) + 1]] <- create_table_rtf(rs, ts, pi,
blnk_ind, wrap_flag,
lpg_rows, pgind, styles)
}
}
ret <- list(widths = widths_uom, page_list = pg_lst)
return(ret)
}
#' @noRd
create_table_rtf <- function(rs, ts, pi, content_blank_row, wrap_flag,
lpg_rows, pgind, styles) {
rh <- rs$row_height
shdrs <- list(lines = 0, twips = 0)
hdrs <- list(lines = 0, twips = 0)
if (ts$headerless == FALSE) {
shdrs <- get_spanning_header_rtf(rs, ts, pi)
hdrs <- get_table_header_rtf(rs, ts, pi$col_width,
pi$label, pi$label_align, pi$table_align)
}
# rs, ts, widths, algns, halgns, talgn
rws <- get_table_body_rtf(rs, pi$data, pi$col_width,
pi$col_align, pi$table_align, ts$borders,
ts$first_row_blank, ts$continuous, styles, pgind)
# Default to content width
ls <- rs$content_size[["width"]]
# Get table width
if (!is.null(pi$col_width))
ls <- sum(pi$col_width, na.rm = TRUE)
if (!is.null(ts$title_hdr))
ttls <- get_title_header_rtf(ts$title_hdr, ls, rs, pi$table_align)
else
ttls <- get_titles_rtf(ts$titles, ls, rs, pi$table_align)
if (!is.null(rs$page_by)) {
pgby <- get_page_by_rtf(rs$page_by, rs$content_size[["width"]],
pi$page_by, rs, pi$table_align)
} else if(!is.null(ts$page_by))
pgby <- get_page_by_rtf(ts$page_by, ls, pi$page_by, rs, pi$table_align)
else
pgby <- c()
a <- NULL
if (content_blank_row %in% c("above", "both"))
a <- paste0("\\par", a)
blnks <- c()
# Get row count by summing ..row variable
# if ("..row" %in% names(pi$data)) {
# rcnt <- sum(pi$data$..row)
# } else {
# rcnt <- nrow(pi$data)
# }
# Determine sum of all lines
rc <- sum(ttls$lines, pgby$lines, shdrs$lines,
hdrs$lines, rws$lines,
length(a))
# Get footnotes, passing in sum of all current lines
ftnts <- get_page_footnotes_rtf(rs, ts, ls, lpg_rows, rc,
wrap_flag, content_blank_row, pi$table_align)
# Deal with cell padding. Don't count this in line count.
cp <- paste0("\\li", rs$cell_padding, "\\ri", rs$cell_padding, rs$spacing_multiplier)
# On LibreOffice, have to protect the table from the title width or
# the table row will inherit the title row width. Terrible problem.
tpt <- "{\\pard\\fs1\\sl0\\par}"
if (any(ts$borders %in% c("all", "top", "outside"))) {
if (ttls$border_flag | rs$page_template$titles$border_flag |
rs$page_template$title_hdr$border_flag)
tpt <- ""
if (length(pgby) > 0) {
if (pgby$border_flag)
tpt <- ""
}
}
if (titles_aligned(ts$titles, ts$title_hdr))
tpt <- ""
# Same thing as above with titles. If footnote block is contiguous
# with table and footnotes are wider than table, row width of footnotes
# will infect row width of table. On libre only. So this is to protect
# the table width.
bpt <- "{\\pard\\fs1\\sl0\\par}"
if (any(ts$borders %in% c("all", "top", "outside", "body"))) {
if (!is.null(ftnts)) {
if (ftnts$border_flag)
bpt <- ""
}
if (!is.null(rs$page_template$footnotes)) {
if (rs$page_template$footnotes$border_flag)
bpt <- ""
}
}
if (footnotes_aligned(ts$footnotes))
bpt <- ""
# Continuous tables are different
# Titles only on first page and footnotes only on last page
if (ts$continuous) {
if ("first" %in% pgind & "last" %in% pgind) {
ret <- list(rtf = c(a, cp, ttls$rtf, pgby$rtf, shdrs$rtf,
hdrs$rtf, rws$rtf, ftnts$rtf),
lines = rc + ftnts$lines)
} else if ("first" %in% pgind) {
ret <- list(rtf = c(a, cp, ttls$rtf, pgby$rtf, shdrs$rtf,
hdrs$rtf, rws$rtf),
lines = rc )
} else if ("last" %in% pgind) {
ret <- list(rtf = c(pgby$rtf,
rws$rtf, ftnts$rtf),
lines = rc + ftnts$lines - ttls$lines)
} else {
ret <- list(rtf = c( pgby$rtf,
rws$rtf),
lines = rc - ttls$lines)
}
} else {
# By default, repeat titles and footnotes on every page
ret <- list(rtf = c(a, cp, ttls$rtf, cp, pgby$rtf, tpt, cp, shdrs$rtf,
hdrs$rtf, rws$rtf, bpt, cp, ftnts$rtf),
lines = rc + ftnts$lines)
}
return(ret)
}
get_page_footnotes_rtf <- function(rs, spec, spec_width, lpg_rows, row_count,
wrap_flag, content_blank_row, talgn) {
ftnts <- list(lines = 0, twips = 0, border_flag = FALSE)
vflag <- "none"
# Deal with valign parameter
if (!is.null(spec$footnotes)) {
if (!is.null(spec$footnotes[[length(spec$footnotes)]])) {
if (spec$footnotes[[length(spec$footnotes)]]$valign == "bottom") {
vflag <- "bottom"
ftnts <- get_footnotes_rtf(spec$footnotes,
spec_width, rs,
talgn)
} else {
vflag <- "top"
ftnts <- get_footnotes_rtf(spec$footnotes, spec_width, rs, talgn)
}
}
} else {
if (!is.null(rs$footnotes[[1]])) {
if (!is.null(rs$footnotes[[1]]$valign)) {
if (rs$footnotes[[1]]$valign == "top") {
vflag <- "top"
ftnts <- get_footnotes_rtf(rs$footnotes,
spec_width, rs,
talgn)
} else {
if (wrap_flag)
vflag <- "bottom"
}
}
}
}
b <- NULL
blen <- 0
if (content_blank_row %in% c("below", "both")) {
b <- "\\par"
blen <- 1
}
# } else {
# b <- paste0("\\fs1\\sl0\\par\\pard", rs$font_rtf, rs$spacing_multiplier)
# }
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
boff <- 0
if (any(class(spec) == "table_spec") &
any(spec$borders %in% c("all", "inside"))) {
boff <- round(row_count * rs$border_height / rs$row_height)
}
ublnks <- c()
lblnks <- c()
# Determine number of filler lines needed
len_diff <- rs$body_line_count - row_count - ftnts$lines - lpg_rows - blen - boff
if (vflag == "bottom" & len_diff > 0) {
ublnks <- c(b, rep("\\par", len_diff))
} else {
if ((wrap_flag & len_diff > 0)) {
if (vflag == "bottom" | has_bottom_footnotes(rs))
lblnks <- c(rep("\\par", len_diff), b)
} else {
lblnks <- b
}
}
tlns <- sum(ftnts$lines, length(ublnks), length(lblnks))
ret <- list(rtf = c(ublnks, ftnts$rtf, lblnks),
lines = tlns,
twips = tlns * rs$twip_conversion,
border_flag = ftnts$border_flag)
return(ret)
}
# Sub-Functions ---------------------------------------------------------
#' Get content offsets for table header, titles, footnotes, and content blanks.
#' Needed to calculate page breaks accurately.
#' @return A vector of upper and lower offsets
#' @noRd
get_content_offsets_rtf <- function(rs, ts, pi, content_blank_row, pgby_cnt = NULL) {
ret <- c(upper = 0, lower = 0, blank_upper = 0, blank_lower = 0)
cnt <- c(upper = 0, lower = 0, blank_upper = 0, blank_lower = 0)
# Width is normally the width of the table, not the page
wdth <- rs$content_size[["width"]]
if (!is.null(pi$col_width))
wdth <- sum(pi$col_width)
# Default to zero
shdrs <- list(lines = 0, twips = 0)
hdrs <- list(lines = 0, twips = 0)
if (ts$headerless == FALSE) {
shdrs <- get_spanning_header_rtf(rs, ts, pi)
hdrs <- get_table_header_rtf(rs, ts, pi$col_width,
pi$label, pi$label_align,
pi$table_align)
}
# Get title headers or titles
if (is.null(ts$title_hdr))
ttls <- get_titles_rtf(ts$titles, wdth, rs)
else
ttls <- get_title_header_rtf(ts$title_hdr, wdth, rs)
# Get page by if it exists
pgb <- list(lines = 0, twips = 0)
if (!is.null(ts$page_by))
pgb <- get_page_by_rtf(ts$page_by, wdth, NULL, rs, pi$table_align, pgby_cnt)
else if (!is.null(rs$page_by))
pgb <- get_page_by_rtf(rs$page_by, wdth, NULL, rs, pi$table_align, pgby_cnt)
#print(length(pgb))
# print(paste("Table titles:", ttls))
# Add everything up
ret[["upper"]] <- shdrs$twips + hdrs$twips + ttls$twips + pgb$twips
cnt[["upper"]] <- shdrs$lines + hdrs$lines + ttls$lines + pgb$lines
if (content_blank_row %in% c("above", "both")) {
ret[["blank_upper"]] <- rs$line_height
cnt[["blank_upper"]] <- 1
}
ftnts <- get_footnotes_rtf(ts$footnotes, wdth, rs)
rftnts <- get_footnotes_rtf(rs$footnotes, wdth, rs)
if (has_top_footnotes(rs)) {
ret[["lower"]] <- ftnts$twips + rftnts$twips
cnt[["lower"]] <- ftnts$lines + rftnts$lines
} else {
ret[["lower"]] <- ftnts$twips
cnt[["lower"]] <- ftnts$lines
}
# Add extra offsets if table has a lot of borders turned on
# to avoid undesired page wraps
if (any(ts$borders %in% c("all", "inside"))) {
ret[["lower"]] <- ret[["lower"]] + (rs$row_height * 2)
cnt[["lower"]] <- cnt[["lower"]] + 2
}
if (content_blank_row %in% c("both", "below")) {
ret[["blank_lower"]] <- rs$line_height
cnt[["blank_lower"]] <- 1
}
res <- list(lines = cnt,
twips = ret)
return(res)
}
#' @description Return a vector of strings for the table header
#' @details Basic idea of this function is to create a list
#' of string vectors of label words sized according to the column
#' widths, then combine by line/row, and concatenate everything and justify.
#' @noRd
get_table_header_rtf <- function(rs, ts, widths, lbls, halgns, talgn) {
ret <- c()
cnt <- 0
rh <- rs$row_height
tbl <- ts$data
conv <- rs$twip_conversion
nms <- names(lbls)
nms <- nms[!is.controlv(nms)]
# Get cell widths
sz <- c()
for (k in seq_along(widths)) {
if (!is.control(nms[k])) {
if (k == 1)
sz[k] <- round(widths[k] * conv)
else
sz[k] <- round(widths[k] * conv + sz[k - 1])
}
}
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
brdrs <- ts$borders
if (length(ts$col_spans) > 0) {
if (any(ts$borders %in% c("outside")))
brdrs <- c("left", "right")
if (any(ts$borders %in% "top"))
brdrs <- brdrs[!brdrs %in% "top"]
}
# Header Cell alignment
ha <- c()
for (k in seq_along(halgns)) {
if (!is.control(nms[k])) {
if (halgns[k] == "left")
ha[k] <- "\\ql"
else if (halgns[k] == "right")
ha[k] <- "\\qr"
else if (halgns[k] %in% c("center", "centre"))
ha[k] <- "\\qc"
}
}
# Table Header
# Request from Astellas
# Need to watch this for undesired side effects.
if (ts$continuous)
ret[1] <- paste0("\\trowd\\trkeep\\trhdr\\trgaph0", ta, "\\trrh", rh)
else
ret[1] <- paste0("\\trowd\\trgaph0", ta, "\\trrh", rh)
# Loop for cell definitions
for(j in seq_along(nms)) {
if (!is.control(nms[j])) {
b <- get_cell_borders(1, j, 2, length(nms), brdrs)
ret[1] <- paste0(ret[1], "\\clvertalb", b, "\\clbrdrb\\brdrs\\cellx", sz[j])
}
}
cnt <- 1
# Loop for column names
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
for(k in seq_along(nms)) {
if (!is.control(nms[k])) {
# Split label strings if they exceed column width
tmp <- split_string_rtf(lbls[k], widths[k], rs$units, rs$font)
tb <- tmp$rtf
if (ts$header_bold)
tb <- paste0("\\b ", tmp$rtf, "\\b0")
ret[1] <- paste0(ret[1], ha[k], " ", tb, "\\cell")
# Add in extra lines for labels that wrap
xtr <- tmp$lines
if (xtr > cnt)
cnt <- xtr
}
}
dev.off()
ret[1] <- paste(ret[1], "\\row")
if (ts$first_row_blank == TRUE) {
if (any(brdrs == "body"))
b <- get_cell_borders(1, 1, 3, 1, c("left", "right"))
else
b <- get_cell_borders(1, 1, 3, 1, brdrs)
w <- round(sum(widths, na.rm = TRUE) * conv)
ret[1] <- paste0(ret[1], "\n\\trowd\\trgaph0", ta,
"\\trrh", rh, b, "\\cellx", w,
"\\ql\\cell\\row")
cnt <- cnt + 1
}
res <- list(rtf = ret,
lines = cnt,
twips = cnt * rh)
return(res)
}
# Need to fix this
#' @description Return a vector of rtf strings for the table spanning headers
#' @details Basic idea of this function is to figure out which columns
#' the header spans, add widths, then call get_table_header. Everything
#' from there is the same.
#' @import stats
#' @noRd
get_spanning_header_rtf <- function(rs, ts, pi) {
spns <- ts$col_spans
cols <- pi$keys
cols <- cols[!is.controlv(cols)]
w <- pi$col_width
w <- w[cols]
gutter <- 0
cnt <- c()
# print("Cols:")
# print(cols)
#print(w)
wlvl <- get_spanning_info(rs, ts, pi, w, gutter)
lvls <- sort(seq_along(wlvl), decreasing = TRUE)
# At this point we have a data frame with labels, etc. and spanning
# column widths, and are ready to create spanning header rows
#print(wlvl)
conv <- rs$twip_conversion
talgn <- pi$table_align
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
# Get borders
brdrs <- ts$borders
if (any(ts$borders %in% "bottom"))
brdrs <- brdrs[!brdrs %in% "bottom"]
rh <- rs$row_height
# Format labels for each level
ln <- c()
for (l in lvls) {
s <- wlvl[[l]]
widths <- s$width
names(widths) <- s$name
algns <- s$align
names(algns) <- s$name
lbls <- s$label
names(lbls) <- s$name
cs <- s$col_span
# Get cell widths
sz <- c()
for (k in seq_along(widths)) {
if (k == 1)
sz[k] <- round(widths[k] * conv)
else
sz[k] <- round(widths[k] * conv + sz[k - 1])
}
# Header Cell alignment
ha <- c()
for (k in seq_along(algns)) {
if (algns[k] == "right")
ha[k] <- "\\qr"
else if (algns[k] %in% c("center", "centre"))
ha[k] <- "\\qc"
else
ha[k] <- "\\ql"
}
r <- ""
cnt[length(cnt) + 1] <- 1
# Table Header
r <- paste0("\\trowd\\trgaph0", ta, "\\trrh", rh)
# Label justification, width, and row concatenation
# Loop for cell definitions
for(j in seq_along(sz)) {
# Get cell borders
b <- get_cell_borders(length(wlvl) - l + 1, j, 10, nrow(s), brdrs)
# Add colspans
vl <- lbls[j]
# Special handling of borders for different situations.
# I hate this, but can't see a way around it.
if (any(brdrs %in% c("all", "inside"))) {
sflg <- "B"
if (j > 1) {
if (cs[j] > 1)
sflg <- ""
}
if (vl == "") {
bb <- get_cell_borders(length(lvls) - l + 1, j, length(lvls),
length(sz), brdrs,
flag = sflg)
} else
bb <- b
} else if (all(brdrs == "outside")) {
if (vl == "")
bb <- b
else {
bb <- b #paste0(b, "\\clbrdrb\\brdrs")
}
} else {
if (vl == "") {
bb <- get_cell_borders(length(lvls) - l + 1, j, length(lvls),
length(sz), brdrs,
flag = "")
} else
bb <- b #paste0(b, "\\clbrdrb\\brdrs")
}
if (s$span[j] > 0 & s$underline[j])
r <- paste0(r, "\\clvertalb", bb, "\\clbrdrb\\brdrs\\cellx", sz[j])
else
r <- paste0(r, "\\clvertalb", bb, "\\cellx", sz[j])
}
# Open device context
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Loop for labels
for(k in seq_along(lbls)) {
# Split label strings if they exceed column width
tmp <- split_string_rtf(lbls[k], widths[k], rs$units, rs$font)
if (s$bold[k])
tb <- paste0("\\b ", tmp$rtf, "\\b0")
else
tb <- paste0(" ", tmp$rtf)
# Concat label
r <- paste0(r, ha[k], tb, "\\cell")
# print(lbls[k])
# print(widths[k])
# Add in extra lines for labels that wrap
xtr <- tmp$lines
if (xtr > cnt[length(cnt)])
cnt[length(cnt)] <- xtr
}
dev.off()
r <- paste0(r, "\\row")
ln[[length(ln) + 1]] <- r
}
ret <- unlist(ln)
res <- list(rtf = ret,
lines = sum(cnt),
twips = sum(cnt) * rh)
return(res)
}
#' @description This function counts lines per row independently because
#' the ..row field does not account for page wrapping. Need number
#' of lines on this particular page.
#' @noRd
get_table_body_rtf <- function(rs, tbl, widths, algns, talgn, tbrdrs,
frb, continuous = FALSE, styles, pgind) {
if ("..blank" %in% names(tbl))
flgs <- tbl$..blank
else
flgs <- NA
# Count lines per row
rws <- c()
nms <- names(widths)
nms <- nms[!is.na(nms)]
nms <- nms[!is.controlv(nms)]
wdths <- widths[nms]
if (length(nms) == 1) {
t <- as.data.frame(tbl[[nms]])
names(t) <- nms
} else
t <- tbl[ , nms]
brdrs <- tbrdrs
if (all(tbrdrs == "body"))
brdrs <- c("top", "bottom", "left", "right")
# Deal with outside borders on continuous tables
if (continuous & "outside" %in% brdrs) {
if ("first" %in% pgind & !"last" %in% pgind) {
brdrs <- c("top", "left", "right")
} else if (!"first" %in% pgind & "last" %in% pgind) {
brdrs <- c("bottom", "left", "right")
} else if (!"first" %in% pgind & !"last" %in% pgind) {
brdrs <- c("left", "right")
}
}
# Get line height. Don't want to leave editor default.
rh <- rs$row_height
conv <- rs$twip_conversion
# Get cell widths
sz <- c()
for (k in seq_along(wdths)) {
if (!is.control(nms[k])) {
if (k == 1)
sz[k] <- round(wdths[k] * conv)
else
sz[k] <- round(wdths[k] * conv + sz[k - 1])
}
}
# Table alignment
ta <- "\\trql"
if (talgn == "right")
ta <- "\\trqr"
else if (talgn %in% c("center", "centre"))
ta <- "\\trqc"
# Cell alignment
ca <- c()
for (k in seq_along(algns)) {
if (!is.control(nms[k])) {
if (algns[k] == "left")
ca[k] <- "\\ql"
else if (algns[k] == "right")
ca[k] <- "\\qr"
else if (algns[k] %in% c("center", "centre"))
ca[k] <- "\\qc"
}
}
ret <- c()
pdf(NULL)
par(family = get_font_family(rs$font), ps = rs$font_size)
# Table Body
for(i in seq_len(nrow(t))) {
if (i == 1 & continuous == FALSE)
ret[i] <- paste0("{\\trowd\\trgaph0\\trrh", rh, ta)
else
ret[i] <- paste0("\\trowd\\trgaph0\\trrh", rh, ta)
if (flgs[i] %in% c("B", "L")) {
# Deal with blank and label rows
radj <- 0
if (frb == TRUE)
radj <- 1
b <- get_cell_borders(i + radj, 1, nrow(t) + radj, ncol(t), brdrs, flgs[i])
ret[i] <- paste0(ret[i], b, "\\cellx", max(sz))
} else {
# Loop for cell definitions
for(j in seq_len(ncol(t))) {
if (!is.control(nms[j])) {
radj <- 0
if (frb == TRUE)
radj <- 1
b <- get_cell_borders(i + radj, j, nrow(t) + radj, ncol(t), brdrs, flgs[i])
ret[i] <- paste0(ret[i], b, "\\cellx", sz[j])
}
}
}
mxrw <- 1
if (flgs[i] %in% c("B", "L")) {
# Deal with label rows
vl <- t[i, 1]
# Deal with styles
# if (nms[1] %in% names(styles)) {
# stl <- styles[[nms[1]]]
# if (stl$bold == TRUE) {
# bflg <- FALSE
# if (!is.null(stl$indicator)) {
# if ("labelrow" %in% stl$indicator) {
# if (flgs[i] %in% c("L"))
# bflg <- TRUE
# }
# if (stl$indicator %in% names(tbl)) {
# if (!is.null(tbl[[i, stl$indicator]] )) {
# if (tbl[[i, stl$indicator]] == TRUE) {
# bflg <- TRUE
# }
# }
# }
# } else {
# bflg <- TRUE
# }
# if (bflg) {
# vl <- paste0("\\b ", vl, "\\b0")
# }
# }
# }
stl <- get_cell_styles(nms[1], styles, flgs, i, tbl)
if ("bold" %in% stl) {
vl <- paste0("\\b ", vl, "\\b0")
}
ret[i] <- paste0(ret[i], ca[1], " ", vl, "\\cell")
cl <- strsplit(vl, "\\line", fixed = TRUE)[[1]]
if (length(cl) > mxrw)
mxrw <- length(cl)
} else {
# Loop for cell values
for(j in seq_len(ncol(t))) {
if (!is.control(nms[j])) {
tb <- t[i, j]
# if (nms[j] %in% names(styles)) {
# stl <- styles[[nms[j]]]
# if (stl$bold == TRUE) {
# bflg <- TRUE
# if (!is.null(stl$indicator)) {
# if ("datarow" %in% stl$indicator) {
# if (flgs[i] %in% c("B", "L"))
# bflg <- FALSE
#
# } else {
# bflg <- FALSE
# if (stl$indicator %in% names(tbl)) {
# if (!is.null(tbl[[i, stl$indicator]] )) {
# if (tbl[[i, stl$indicator]] == TRUE) {
# bflg <- TRUE
# }
# }
# }
#
# }
# }
# if (bflg) {
# tb <- paste0("\\b ", tb, "\\b0")
# }
# }
# }
stl <- get_cell_styles(nms[j], styles, flgs, i, tbl)
if ("bold" %in% stl) {
tb <- paste0("\\b ", tb, "\\b0")
}
# Construct rtf
ret[i] <- paste0(ret[i], ca[j], " ", tb, "\\cell")
vl <- t[i, j]
if (all(class(vl) != "character"))
vl <- as.character(vl)
# Count lines in cell
cl <- strsplit(vl, "\\line", fixed = TRUE)[[1]]
if (length(cl) > mxrw)
mxrw <- length(cl)
}
}
}
rws[i] <- mxrw
ret[i] <- paste0(ret[i], "\\row")
}
dev.off()
if (!continuous) {
ret[length(ret)] <- paste0(ret[length(ret)], "}\\pard",
rs$font_rtf, rs$spacing_multiplier)
} else {
ret[length(ret)] <- paste0(ret[length(ret)], "") # Not needed
}
res <- list(rtf = ret,
lines = sum(rws))
return(res)
}
# Utility Functions -------------------------------------------------------
titles_aligned <- function(ttls = NULL, ttlhdrs = NULL) {
lst <- ttlhdrs
if (!is.null(ttls))
lst <- ttls
ret <- FALSE
if (!is.null(lst)) {
lastttl <- lst[[length(lst)]]
if (lastttl$width == "content")
ret <- TRUE
}
return(ret)
}
footnotes_aligned <- function(ftnts = NULL) {
lst <- ftnts
ret <- FALSE
if (!is.null(lst)) {
lastfnt <- lst[[1]]
if (lastfnt$width == "content" & lastfnt$valign == "top")
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.