[R] Advanced Level Script for Traceability Between Worksheets
C Campbell
cc571309 at gmail.com
Sat Aug 29 22:19:35 CEST 2015
Hi folks - I have almost know R skills yet and have been put 'in charge' of
the below script created by a former employee. Although some of this is
understandable to me, much of it is not. If anyone can help with
explaining sections, commenting on the skill level it takes to understand
this level of scripting in R, and/or point me to some resources that may
cover some of this (e.g., what is ..A[..B, in_B := TRUE, allow.cartesian =
TRUE]; and specifically what do the 2 dots mean?), I would very much
appreciate it. Would also be interested in communicating offline if you
prefer.
Thank you,
Jay
# Locate file ####
parameterization_file <- file.choose()
cd <- dirname(parameterization_file)
# Front matter ####
message("Installing and loading packages...")
# Packages
required_packages <- c("openxlsx", "xlsx", "magrittr", "data.table",
"reshape2",
"XML")
install_these <- setdiff(required_packages, rownames(installed.packages()))
while (length(install_these) > 0) {
install.packages(install_these, repos = "http://cran.rstudio.com")
install_these <- setdiff(required_packages,
rownames(installed.packages()))
}
suppressPackageStartupMessages(library(openxlsx))
suppressPackageStartupMessages(library(magrittr))
suppressPackageStartupMessages(library(data.table))
suppressPackageStartupMessages(library(reshape2))
suppressPackageStartupMessages(library(XML))
# Options
options(stringsAsFactors = FALSE)
# Functions
message("Loading functions...")
A__in__B <- function(A, B, case = TRUE, ...) {
# Copies
..A <- copy(A)
..B <- copy(B)
setkey(..A, value)
setkey(..B, value)
..A <- unique(..A)
..B <- unique(..B)
# Rownames are unnecessary
..A[, rn := NULL]
..B[, rn := NULL]
# Case sensitivity
if (!case) {
..A <- tableToLower(..A)
..B <- tableToLower(..B)
}
# Check if A is in B
..A[..B, in_B := TRUE, allow.cartesian = TRUE]
if ("in_B" %in% names(..A))
..A[is.na(in_B), in_B := FALSE]
else
..A[, in_B := FALSE]
# Case sensitivity
if (!case)
..A <- tableDropLower(..A)
# Set attributes
setABattr(..A, A, B)
# Return results
setkey(..A, value)
return(..A)
}
A__unique <- function(A, case = TRUE, ...) {
# Copies
..A <- copy(A)
setkey(..A, value)
# Case sensitivity
if (!case)
..A <- tableToLower(..A)
# Check if A_i values are unique
..A[..A[duplicated(..A), SJ(value)], is_unique := FALSE,
allow.cartesian = TRUE]
if ("is_unique" %in% names(..A))
..A[is.na(is_unique), is_unique := TRUE]
else
..A[, is_unique := TRUE]
# Case sensitivity
if (!case)
..A <- tableDropLower(..A)
# Roll up to value level
..A <- ..A[, list(is_unique = all(is_unique)), keyby = value]
# Return results
return(..A)
}
A_i__in__B <- function(A, B, case = TRUE, ...) {
# Copies
..A <- copy(A)
setkey(..A, value, rn)
..A <- unique(..A)
..B <- copy(B)
setkey(..B, value)
..B %>% unique
# B rownames are unnecessary
..B[, rn := NULL]
# Case sensitivity
if (!case) {
..A <- tableToLower(..A)
..B <- tableToLower(..B)
}
# Check if A is in B
if ("in_B" %in% names(..A))
..A[is.na(in_B), in_B := FALSE]
else
..A[, in_B := FALSE]
# Case sensitivity
if (!case)
..A <- tableDropLower(..A)
# Set attributes
setABattr(..A, A, B)
# Return results
setkey(..A, value, rn)
return(..A)
}
A_i__in__B_i <- function(A, B, case = TRUE, ...) {
# Copies
..A <- copy(A)
setkey(..A, value, rn)
..A <- unique(..A)
..B <- copy(B)
setkey(..B, value, rn)
..B <- unique(..B)
# Case sensitivity
if (!case) {
..A <- tableToLower(..A)
..B <- tableToLower(..B)
}
# Check if A_i terms are in B_i terms
..A[..B, in_B := TRUE, allow.cartesian = TRUE]
if ("in_B" %in% names(..A))
..A[is.na(in_B), in_B := FALSE]
else
..A[, in_B := FALSE]
# Case sensitivity
if (!case)
..A <- tableDropLower(..A)
# Set attributes
setABattr(..A, A, B)
# Return results
setkey(..A, value, rn)
return(..A)
}
A_i__substr__B_i <- function(A, B, case = TRUE, ...) {
# Copies
..A <- copy(A)
setkey(..A, rn)
..B <- copy(B)
setkey(..B, rn)
# Renames
setnames(..A, "value", "A_value")
setnames(..B, "value", "B_value")
# Merge
..X <- ..B[..A, allow.cartesian = TRUE]
# Check if A_i values are substrings of B_i values
..X[is.na(B_value), is_substring := FALSE]
Encoding(..X$A_value) <- "UTF-8"
Encoding(..X$B_value) <- "UTF-8"
if (case) {
..X[!is.na(B_value), is_substring := mapply(
grepl, A_value, B_value, fixed = TRUE)]
} else {
..X[!is.na(B_value), is_substring := mapply(
grepl, tolower(A_value), tolower(B_value), fixed = TRUE)]
}
Encoding(..X$A_value) <- "bytes"
Encoding(..X$B_value) <- "bytes"
# Rename/reorder
..X <- ..X[, list(value = A_value, rn, is_substring)]
# Set attributes
setABattr(..X, A, B)
# Return results
setkey(..X, value, rn)
return(..X)
}
A_i__unique <- function(A, case = TRUE, ...) {
# Copies
..A <- copy(A)
setkey(..A, value)
# Case sensitivity
if (!case)
..A <- tableToLower(..A)
# Check if A_i values are unique
..A[..A[duplicated(..A), SJ(value)], is_unique := FALSE,
allow.cartesian = TRUE]
if ("is_unique" %in% names(..A))
..A[is.na(is_unique), is_unique := TRUE]
else
..A[, is_unique := TRUE]
# Case sensitivity
if (!case)
..A <- tableDropLower(..A)
# Return results
setkey(..A, value, rn)
return(..A)
}
extractColumn <- function(x, column_name, value_delimiter = NULL, rows =
NULL)
{
# Validate formatting on column name args
column_name %<>% trimCompress
# Multiple columns?
mult_cols <- grepl(",", column_name)
if (mult_cols)
column_name %<>% strsplit(",") %>% unlist %>% trimCompress
# Get column + rn
..table <- x[, c("rn", column_name), with = FALSE]
setnames(..table, 2, "value")
# Long if multiple
if (mult_cols) {
..table %<>% melt(1)
..table[, variable := NULL]
}
# Key table by rowname
setkey(..table, rn)
# If rows was provided, subset
if (!is.null(rows))
if (rows != "All")
..table <- ..table[textrange2vector(rows) %>% SJ]
# Split values according to delimiter...
dlm <- Rdelim(value_delimiter)
if (!is.null(dlm))
..values <- strsplit(..table[, value], Rdelim(value_delimiter)) %>%
lapply(trimCompress)
# ... or convert to list if no delimiter
else
..values <- ..table[, value] %>% trimCompress %>% as.list
# Set list name values to rowname values
names(..values) <- ..table[, rn]
# Convert from list to table
..values %<>% melt %>% as.data.table
setnames(..values, 2, "rn")
# Remove any instances of blank values
..values <- ..values[!is.na(value) & grepl("[^[:space:]]", value)]
# Encode all text to bytes
# Will need to encode to UTF-8 before output to make it readable
Encoding(..values$value) <- "bytes"
if (is.character(..values$rn)) Encoding(..values$rn) <- "bytes"
# If row names can be converted to numeric, do so
if (..values[, rn] %>% is.character)
if (..values[, rn] %>% type.convert %>% is.numeric)
..values[, rn := as.numeric(rn)]
# Key table by value
setkey(..values, value, rn)
# Add attributes
setattr(..values, "file_path", attr(x, "file_path"))
setattr(..values, "sheet_name", attr(x, "sheet_name"))
setattr(..values, "header_row", attr(x, "header_row"))
setattr(..values, "column_name", column_name)
setattr(..values, "rownames_name", attr(x, "rownames_name"))
setattr(..values, "value_delimiter", value_delimiter)
setattr(..values, "rows", rows)
# Return the values table
return(..values)
}
fillNAlast <- function(x) {
na <- is.na(x)
miss <- which(na)
nonmiss <- which(!na)
map <- outer(nonmiss, miss, "<") %>%
apply(2, . %>% which %>% max)
x[miss] <- x[nonmiss[map]]
return(x)
}
getSheetIndex <- function(file_path, sheet_name) {
# Extract workbook.xml to temporary file that will be deleted at end of
# run
xmlDir <- file.path(tempdir(), "findSheet")
workbook <- unzip(file_path, files = "xl/workbook.xml", exdir = xmlDir)
on.exit(unlink(xmlDir, recursive = TRUE), add = TRUE)
# Read workbook.xml and get sheet nodes
workbook <- readLines(workbook, warn = FALSE, encoding = "UTF-8") %>%
unlist
sheets <- gregexpr("<sheet .*/sheets>", workbook, perl = TRUE) %>%
regmatches(workbook, .) %>%
unlist
# Extract sheet names from nodes, parse as html, and return text
values
sheetNames <- gregexpr('(?<=name=")[^"]+', sheets, perl = TRUE) %>%
regmatches(sheets, .) %>%
unlist %>%
lapply(htmlParse, asText = TRUE) %>%
sapply(. %>% xpathApply("//body//text()", xmlValue) %>% unlist)
# Which sheet name is equal to the sheet_name argument?
which(sheetNames == sheet_name)
}
Rdelim <- function(x, ...) {
if (!is.null(x)) {
if (!is.na(x) & x != "None") {
if (x == "Newline") "\\n" else x
} else NULL
} else NULL
}
readSource <- function(file_path, sheet_name, header_row, column_names,
rownames_name = NULL)
{
# Validate formatting on column name args
column_names %<>% strsplit(",") %>% unlist %>% trimCompress
rownames_name %<>% trimCompress
# Sheet index
sheet_index <- getSheetIndex(file_path, sheet_name)
# Read column names according to header row
..names <- read.xlsx(
xlsxFile = file_path
, sheet = sheet_index
, colNames = FALSE
, rows = header_row
) %>% unlist %>% unname %>% trimCompress
# Read in column plus and any rownames column
..table <- read.xlsx(
xlsxFile = file_path
, sheet = sheet_index
, startRow = header_row
, cols = which(..names %in% c(rownames_name, column_names))
, skipEmptyRows = FALSE
, detectDates = TRUE
) %>% as.data.table
# Set names
setnames(..table,
..names[which(..names %in% c(rownames_name, column_names))])
# Rownames
## If no rownames column, use row number
if (is.null(rownames_name)) {
if (is.null(rows)) ..table[, rn := 1:.N + 1L] else ..table[, rn := rows]
} else { # Otherwise, just copy the column
..table[, rn := lapply(.SD, identity), .SDcols = rownames_name]
}
setcolorder(..table, c("rn", setdiff(names(..table), "rn")))
# If row can be converted to numeric, do so
if (..table[, rn] %>% is.character)
if (..table[, rn] %>% type.convert %>% is.numeric)
..table[, rn := as.numeric(rn)]
# Key table by row
setkey(..table, rn)
# Add attributes
setattr(..table, "file_path", file_path)
setattr(..table, "sheet_name", sheet_name)
setattr(..table, "header_row", header_row)
setattr(..table, "column_names", column_names)
setattr(..table, "rownames_name", rownames_name)
# Return the values table
return(..table)
}
setABattr <- function(new_table, A, B) {
# Strip existing attributes in new_table
setattr(new_table, "file_path", NULL)
setattr(new_table, "sheet_name", NULL)
setattr(new_table, "header_row", NULL)
setattr(new_table, "column_name", NULL)
setattr(new_table, "rownames_name", NULL)
setattr(new_table, "value_delimiter", NULL)
setattr(new_table, "rows", NULL)
setattr(new_table, "rows_are_rownames", NULL)
# Set A attributes in new_table
setattr(new_table, "A_file_path", attributes(A)$file_path)
setattr(new_table, "A_sheet_name", attributes(A)$sheet_name)
setattr(new_table, "A_header_row", attributes(A)$header_row)
setattr(new_table, "A_column_name", attributes(A)$column_name)
setattr(new_table, "A_rownames_name", attributes(A)$rownames_name)
setattr(new_table, "A_value_delimiter", attributes(A)$value_delimiter)
setattr(new_table, "A_rows", attributes(A)$rows)
setattr(new_table, "A_rows_are_rownames", attributes(A)$rows_are_rownames)
# Set B attributes in new_table
setattr(new_table, "B_file_path", attributes(B)$file_path)
setattr(new_table, "B_sheet_name", attributes(B)$sheet_name)
setattr(new_table, "B_header_row", attributes(B)$header_row)
setattr(new_table, "B_column_name", attributes(B)$column_name)
setattr(new_table, "B_rownames_name", attributes(B)$rownames_name)
setattr(new_table, "B_value_delimiter", attributes(B)$value_delimiter)
setattr(new_table, "B_rows", attributes(B)$rows)
setattr(new_table, "B_rows_are_rownames", attributes(B)$rows_are_rownames)
}
tableToLower <- function(X, ...) {
# Copy
x <- copy(X)
# Existing keys
keys <- key(x)
setkey(x, NULL)
# Rename value column
setnames(x, "value", "value_orig")
# Derived value column
Encoding(x$value_orig) <- "UTF-8"
x[, value := tolower(value_orig)]
Encoding(x$value) <- "bytes"
Encoding(x$value_orig) <- "bytes"
# Rekey
setkeyv(x, keys)
# Return
return(x)
}
tableDropLower <- function(X, ...) {
# Copy
x <- copy(X)
# Existing keys
keys <- key(x)
setkey(x, NULL)
# Drop derived value column
x[, value := NULL]
# Rename value_orig column
setnames(x, "value_orig", "value")
# Rekey
setkeyv(x, keys)
# Return
return(x)
}
textrange2vector <- function(x) {
strsplit(x, ",") %>%
lapply(
. %>%
strsplit("-") %>%
lapply(as.numeric) %>%
lapply(function(s)
if (length(s) == 1) s
else seq(s[1], s[2]))) %>%
lapply(unlist)
}
trimCompress <- function(x) {
if (!"magrittr" %in% loadedNamespaces()) # check if magrittr is loaded
library(magrittr) # load if not
if (is.null(x)) return(NULL)
x %>%
gsub("^\\s+", "", .) %>% # remove leading blanks
gsub("\\s+$", "", .) %>% # remove trailing blanks
gsub("\\s+", " ", .) # compress multiple blanks to one
}
# Read parameterization file ####
message("Reading parameters...")
## Catalog parameters
avail_params <- read.xlsx(
parameterization_file
, "Available Parameters"
, colNames = FALSE
, startRow = 2
) %>% as.data.table
sheet_params <- c("name", "path", "sheet", "header", "rn")
setnames(avail_params, 1:5, sheet_params)
avail_params <- avail_params[!is.na(name) & grepl("[^[:space:]]", name)] %>%
melt(id.vars = 1:5, value.name = "columns")
avail_params <- avail_params[, lapply(.SD, . %>% Filter(Negate(is.na), .)
%>%
list), by = eval(sheet_params)]
avail_params[, variable := NULL]
## Analysis parameters
analysis_params <- read.xlsx(
parameterization_file
, "Parameterization"
, startRow = 2
, colNames = FALSE
) %>% as.data.table
setnames(analysis_params, c(
"name1", "col1", "rows1", "dlm1",
"verb", "case",
"name2", "col2", "rows2", "dlm2",
"outname", "outcols", "outflat"
))
analysis_params <- analysis_params[-1][!is.na(name1) &
grepl("[^[:space:]]", name1)]
analysis_params[, n := 1:.N]
## Combine parameters
setkey(avail_params, name)
setkey(analysis_params, name1)
analysis_params[avail_params, ":="(
path1 = path
,sheet1 = sheet
,header1 = header
,rn1 = rn
), allow.cartesian = TRUE]
setkey(analysis_params, name2)
analysis_params[avail_params, ":="(
path2 = path
,sheet2 = sheet
,header2 = header
,rn2 = rn
), allow.cartesian = TRUE]
setkey(analysis_params, n)
# Match actions to functions
verb_function_map <- list(
"A_i__in__B" = c("In", "Not In"),
"A_i__in__B_i" = c("In (Same Row)", "Not In (Same Row)"),
"A_i__substr__B_i" = c("Substring Of (Same Row)",
"Not Substring Of (Same Row)"),
"A_i__unique" = c("Is Unique", "Not Unique")
) %>% unlist
names(verb_function_map) %<>% gsub("[0-9]+", "", .)
analysis_params[, fun := factor(verb)]
levels(analysis_params$fun) %<>%
match(verb_function_map) %>%
"["(names(verb_function_map), .)
analysis_params$fun %<>% as.character
# Read data sources
message("Reading data sources...")
data_names <- avail_params[, name]
data_list <- replicate(length(data_names), list(), simplify = FALSE)
names(data_list) <- data_names
for (i in 1:nrow(avail_params))
data_list[[i]] <- with(avail_params[i], readSource(
file_path = path
, sheet_name = sheet
, header_row = header
, column_names = columns[[1]]
, rownames_name = rn
))
# Analysis ####
message("Performing comparisons...")
reports <- analyses <- vector("list", nrow(analysis_params))
names(reports) <- names(analyses) <- analysis_params[, outname]
rowAnalysis2report <- function(analysis, params = list()) {
# Create a copy
x <- copy(analysis)
# Subset to logical_val of logical_col
setnames(x, setdiff(names(x), c("rn", "value")), "logical_col")
x <- x[logical_col == !grepl("Not", params$verb)]
x[, logical_col := NULL]
# Re-encode
Encoding(x$value) <- "UTF-8"
if (is.character(x$rn))
Encoding(x$rn) <- "UTF-8"
# Unique results only
setkey(x, rn, value)
setcolorder(x, key(x))
x <- unique(x)
# Flatten if desired
if (params$outflat == "Yes") {
dlm <- Rdelim(params$dlm1)
if (!is.null(dlm)) {
if (dlm == "\\n") dlm <- "\n"
x <- x[, list(value = paste(value, collapse = dlm)), by = rn]
}
}
# Retrieve all columns if desired
setkey(x, rn)
if (params$outcols == "Yes") {
full_source <- copy(data_list[[params$name1]])
setkey(full_source, rn)
x <- x[full_source, nomatch = 0, allow.cartesian = TRUE]
}
# Rename results columns
if (is.null(params$rn1)) setnames(x, 1, "Row") else {
if (is.na(params$rn1) | params$rn1 == params$col1) setnames(x, 1,
"Row")
else setnames(x, 1, params$rn1)
}
setnames(x, 2, params$col1)
return(x)
}
## Do it
for (i in 1:nrow(analysis_params)) {
r <- analysis_params[i]
args <- list(
A = extractColumn(data_list[[r$name1]], r$col1, r$dlm1, r$rows1),
B = if (!is.na(r$name2))
extractColumn(data_list[[r$name2]], r$col2, r$dlm2, r$rows2),
case = (r$case == "Yes")
)
analyses[[i]] <- do.call(r$fun, args)
reports[[i]] <- rowAnalysis2report(analyses[[i]], r)
rm(r, args)
}
# Output ####
message("Writing results to output file...")
detach("package:openxlsx")
suppressPackageStartupMessages(library(xlsx))
# Output file
exists <- TRUE
i <- 0
while (exists) {
out_file <- if (i > 0) {
file.path(cd, sprintf("Comparison_Reports_%s_(%s).xlsx", Sys.Date(), i))
} else file.path(cd, sprintf("Comparison_Reports_%s.xlsx", Sys.Date()))
exists <- file.exists(out_file)
if (!exists)
file.copy(parameterization_file, out_file)
i <- i + 1
}
# Headers
headers <- analysis_params[, lapply(.SD, as.character), .SDcols = c(
"outname", "col1", "verb", "col2", "case", "name1", "name2",
"rows1", "rows2", "dlm1", "dlm2")]
headers[, case := factor(case, c("Yes", "No"),
c("(Case Sensitive)", "(Not Case Sensitive)"))]
headers[!is.na(col2), header_title := paste(col1, verb, col2, case)]
headers[is.na(col2), header_title := paste(col1, verb, case)]
headers[, header_time := Sys.time()]
headers$header_col1 <- headers[, list(col1, name1, rows1, dlm1)] %>%
t %>%
as.data.table %>%
lapply(as.list) %>%
lapply(as.data.table) %>%
lapply(setnames, c("Column", "Source", "Rows", "Delimiter")) %>%
lapply(as.list)
headers$header_col2 <- headers[, list(col2, name2, rows2, dlm2)] %>%
t %>%
as.data.table %>%
lapply(as.list) %>%
lapply(as.data.table) %>%
lapply(setnames, c("Column", "Source", "Rows", "Delimiter")) %>%
lapply(as.list)
# Write
keep <- c(ls(), "i", "keep")
## Loop through reports and write
for (i in names(reports)) {
message(i, "...")
# Load workbook
wb <- loadWorkbook(out_file)
# Workbook styles
## Header title
hd <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP"),
font = Font(wb, heightInPoints = 16, isBold = TRUE)
)
## Date
dt <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP"),
dataFormat = DataFormat("m/d/yyyy h:mm:ss;@")
)
## Parameters header
ph <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP"),
font = Font(wb, isItalic = TRUE)
)
## Column names header
cn <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP"),
border = Border(position = c("BOTTOM", "TOP"),
pen = c("BORDER_THIN", "BORDER_MEDIUM")),
font = Font(wb, isBold = TRUE)
)
## Column names header for reproduced data
cnr <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP"),
border = Border(position = c("BOTTOM", "TOP"),
pen = c("BORDER_THIN", "BORDER_MEDIUM")),
font = Font(wb, isBold = TRUE, isItalic = TRUE)
)
## Values
vl <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP",
wrapText = TRUE)
)
## Values for reproduced data
vlr <- CellStyle(
wb,
alignment = Alignment(horizontal = "ALIGN_LEFT", vertical =
"VERTICAL_TOP",
wrapText = TRUE),
font = Font(wb, isItalic = TRUE)
)
# Create sheet
sh <- createSheet(wb, i)
# Add header rows
h <- headers[outname == i]
addMergedRegion(sh, 1, 1, 1, 10)
addMergedRegion(sh, 2, 2, 1, 10)
rw <- createRow(sh, 1:2)
cl <- createCell(rw, 1)
## Title
addDataFrame(h[, header_title], sh, FALSE, FALSE, 1, 1)
rw <- getRows(sh, 1)
cl <- getCells(rw)
lapply(cl, setCellStyle, hd)
## Date
addDataFrame(h[, header_time], sh, FALSE, FALSE, 2, 1)
rw <- getRows(sh, 2)
cl <- getCells(rw)
lapply(cl, setCellStyle, dt)
## Parameters
addDataFrame(h[, header_col1] %>% as.data.frame, sh, TRUE, FALSE, 4, 1)
if (h[, !is.na(col2)])
addDataFrame(h[, header_col2] %>% as.data.frame, sh, FALSE, FALSE, 6, 1)
rw <- getRows(sh, 4)
cl <- getCells(rw)
lapply(cl, setCellStyle, ph)
rw <- getRows(sh, 5:6)
cl <- getCells(rw)
lapply(cl, setCellStyle, vl)
# Add report
addDataFrame(reports[[i]], sh, TRUE, FALSE, 8, 1)
nc <- ncol(reports[[i]])
## Format column names
rw <- getRows(sh, 8)
cl <- getCells(rw, 1:2)
lapply(cl, setCellStyle, cn)
if (nc > 2) {
cl <- getCells(rw, 3:nc)
lapply(cl, setCellStyle, cnr)
}
## Format values
rw <- getRows(sh, 9:(nrow(reports[[i]]) + 9))
cl <- getCells(rw, 1:2)
lapply(cl, setCellStyle, vl)
if (nc > 2) {
cl <- getCells(rw, 3:nc)
lapply(cl, setCellStyle, vlr)
}
## Add autofilters
if (ncol(reports[[i]]) > 26) {
addAutoFilter(sh, sprintf("A8:%s%s%s",
LETTERS[floor(ncol(reports[[i]]) / 26)],
LETTERS[ncol(reports[[i]]) %% 26],
nrow(reports[[i]]) + 9))
} else {
addAutoFilter(sh, sprintf("A8:%s%s", LETTERS[ncol(reports[[i]])],
nrow(reports[[i]]) + 9))
}
# Autofit columns
autoSizeColumn(sh, 1:ncol(reports[[i]]))
# Create freeze on report column names and results columns
if (nc > 2) createFreezePane(sh, rowSplit = 9, colSplit = 3) else
createFreezePane(sh, rowSplit = 9, colSplit = 1)
# Save
saveWorkbook(wb, out_file)
rm(list = setdiff(ls(), keep))
}
b
[[alternative HTML version deleted]]
More information about the R-help
mailing list