Nothing
### This file is part of 'augmentedRCBD' package for R.
### Copyright (C) 2015-2023, ICAR-NBPGR.
#
# augmentedRCBD is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# augmentedRCBD is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# A copy of the GNU General Public License is available at
# https://www.r-project.org/Licenses/
#' Generate MS Word or Excel Report from \code{augmentedRCBD} Output
#'
#' \code{report.augmentedRCBD} generates a tidy report from an object of class
#' \code{augmentedRCBD} as docx MS word file using the
#' \code{\link[officer]{officer}} package or xlsx MS excel file using the
#' \code{\link[openxlsx]{openxlsx}} package.
#'
#' @param aug An object of class \code{augmentedRCBD}.
#' @param target The path to the report file to be created.
#' @param file.type The file type of the report. Either \code{"word"} for MS
#' Word report file or \code{"excel"} for MS Excel report file.
#' @param k The standardized selection differential or selection intensity
#' required for computation of Genetic advance. Default is 2.063 for 5\%
#' selection proportion (see \strong{Details} in
#' \code{\link[augmentedRCBD]{gva.augmentedRCBD}}). Ignored if
#' \code{gva = FALSE}.
#' @param check.col The colour(s) to be used to highlight check values in the
#' plot as a character vector. Must be valid colour values in R (named
#' colours, hexadecimal representation, index of colours [\code{1:8}] in
#' default R \code{palette()} etc.).
#'
#' @note The raw values in the \code{augmentedRCBD} object are rounded off to 2
#' digits in the word and excel reports. However, in case of excel report, the
#' raw values are present in the cell and are formatted to display only 2
#' digits.
#'
#' So, if values such as adjusted means are being used of downstream
#' analysis, export the raw values from within R or use the excel report.
#'
#' This default rounding can be changed by setting the global options
#' \code{augmentedRCBD.round.digits}. For example
#' \code{setOption(augmentedRCBD.round.digits = 3)} sets the number of decimal
#' places for rounding to 3.
#'
#' Values will not be rounded to zero, instead will be rounded to the nearest
#' decimal place. F value, t ratio and p values are not rounded to less than 3
#' decimal places.
#'
#' @export
#' @import officer
#' @import flextable
#' @import openxlsx
#' @importFrom dplyr mutate_if
#' @importFrom grDevices png
#' @importFrom grDevices dev.off
#' @importFrom methods is
#' @importFrom stringi stri_pad_right stri_trans_totitle
#' @importFrom graphics plot
#' @importFrom utils capture.output citation stack
#'
#' @seealso \code{\link[officer]{officer}}, \code{\link[flextable]{flextable}}
#'
#' @examples
#' # Example data
#' blk <- c(rep(1,7),rep(2,6),rep(3,7))
#' trt <- c(1, 2, 3, 4, 7, 11, 12, 1, 2, 3, 4, 5, 9, 1, 2, 3, 4, 8, 6, 10)
#' y1 <- c(92, 79, 87, 81, 96, 89, 82, 79, 81, 81, 91, 79, 78, 83, 77, 78, 78,
#' 70, 75, 74)
#' y2 <- c(258, 224, 238, 278, 347, 300, 289, 260, 220, 237, 227, 281, 311, 250,
#' 240, 268, 287, 226, 395, 450)
#' data <- data.frame(blk, trt, y1, y2)
#' # Convert block and treatment to factors
#' data$blk <- as.factor(data$blk)
#' data$trt <- as.factor(data$trt)
#' # Results for variable y1 (checks inferred)
#' out <- augmentedRCBD(data$blk, data$trt, data$y1, method.comp = "lsd",
#' alpha = 0.05, group = TRUE, console = FALSE)
#'
#' \donttest{
#' report.augmentedRCBD(aug = out,
#' target = file.path(tempdir(),
#' "augmentedRCBD output.docx"),
#' file.type = "word",
#' check.col = c("brown", "darkcyan",
#' "forestgreen", "purple"))
#' report.augmentedRCBD(aug = out,
#' target = file.path(tempdir(),
#' "augmentedRCBD output.xlsx"),
#' file.type = "excel",
#' check.col = c("brown", "darkcyan",
#' "forestgreen", "purple"))
#' }
#'
report.augmentedRCBD <- function(aug, target, file.type = c("word", "excel"),
k = 2.063, check.col = "red"){
if (!is(aug, "augmentedRCBD")) {
stop('"aug" is not of class "augmentedRCBD".')
}
file.type <- match.arg(file.type)
# check.col
if (!all(iscolour(check.col))) {
stop('"check.col" specifies invalid colour(s).')
}
checks <- aug$Details$`Check treatments`
if (length(check.col) != 1) {
if (length(check.col) != length(checks)) {
stop('"checks" and "check.col" are of unequal lengths.')
}
}
round.digits <- getOption("augmentedRCBD.round.digits", default = 2)
wstring1 <- "Test treatments are replicated"
wstring2 <- "Negative adjusted means were generated for the following"
if (file.type == "word") {
if (!grepl(x = target, pattern = "\\.(docx)$", ignore.case = TRUE)) {
stop(target, " should have '.docx' extension.")
}
suppar <- fp_text(vertical.align = "superscript")
augreport <- read_docx(file.path(system.file(package = "augmentedRCBD"),
"template.docx"))
augreport <- body_add_par(augreport, value = "augmentedRCBD",
style = "Title")
augreport <- body_add_toc(augreport, level = 2)
# Details
augreport <- body_add_par(augreport, value = "Details",
style = "heading 1")
Details <- t(data.frame(`Number of blocks` = aug$Details$`Number of blocks`,
`Number of treatments` = aug$Details$`Number of treatments`,
`Number of check treatments` = aug$Details$`Number of check treatments`,
`Number of test treatments` = aug$Details$`Number of test treatments`,
`Check treatments` = paste(aug$Details$`Check treatments`,
collapse = ", ")))
Details <- data.frame(Details)
Details <- cbind(gsub("\\.", " ", rownames(Details)), Details)
colnames(Details) <- c("Item", "Details")
Details <- regulartable(data = data.frame(Details))
Details <- autofit(Details)
augreport <- body_add_flextable(augreport, Details)
if (any(grepl(wstring1, aug$warnings))) {
dups <- aug$Means[!(aug$Means$Treatment %in% checks), ]$Treatment
dups <- dups[duplicated(dups)]
dups <- aug$Means[aug$Means$Treatment %in% dups, c("Treatment", "Block")]
rownames(dups) <- NULL
augreport <- body_add_par(augreport, value = "\r\n", style = "Normal")
augreport <- body_add_par(augreport,
value = "Following test treatments are replicated.",
style = "Warning")
augreport <- body_add_flextable(augreport,
theme_alafoli(autofit(regulartable(dups))))
}
anova_warn <- NULL
if (any(!grepl(paste(c(wstring1, wstring2), collapse = "|"),
aug$warnings))) {
anova_warn <- aug$warnings[!grepl(paste(c(wstring1, wstring2),
collapse = "|"),
aug$warnings)]
}
# ANOVA, TA
augreport <- body_add_par(augreport, value = "ANOVA, Treatment Adjusted",
style = "heading 1")
if (is.data.frame(aug$`ANOVA, Treatment Adjusted`)){
anovata <- aug$`ANOVA, Treatment Adjusted`
} else {
anovata <- data.frame(aug$`ANOVA, Treatment Adjusted`[[1]])
anovata <- cbind(Source = trimws(rownames(anovata)), anovata)
}
anovata$sig <- ifelse(anovata$Pr..F. <= 0.01, "**",
ifelse(anovata$Pr..F. <= 0.05, "*", "ns"))
colnames(anovata) <- c("Source", "Df", "Sum Sq", "Mean Sq",
"F value", "Pr(>F)", " ")
anovata$Df <- as.character(anovata$Df)
anovata[, c("Sum Sq", "Mean Sq")] <-
lapply(anovata[, c("Sum Sq", "Mean Sq")], round.conditional,
digits = round.digits)
anovata[, c("F value", "Pr(>F)")] <-
lapply(anovata[, c("F value", "Pr(>F)")], round.conditional,
digits = max(round.digits, 3))
nsindex <- which(anovata[, 7] == "ns")
anovata <- autofit(regulartable(anovata))
if (!is.null(nsindex)) {
anovata <- compose(anovata, part = "body", i = nsindex, j = 7,
value = as_paragraph(as_sup("ns")))
}
anovata <- align(anovata, j = 2:6, align = "right", part = "all")
anovata <- bold(anovata, part = "header")
augreport <- body_add_flextable(augreport, anovata)
augreport <- body_add_fpar(augreport,
value = fpar(ftext("ns", suppar),
ftext(" P > 0.05; * P <= 0.05; ** P <= 0.01")))
if (!is.null(anova_warn)) {
for (i in seq_along(anova_warn)) {
augreport <- body_add_par(augreport, value = anova_warn[i],
style = "Warning")
}
}
# ANOVA, BA
augreport <- body_add_par(augreport, value = "ANOVA, Block Adjusted",
style = "heading 1")
if (is.data.frame(aug$`ANOVA, Block Adjusted`)){
anovaba <- aug$`ANOVA, Block Adjusted`
} else {
anovaba <- data.frame(aug$`ANOVA, Block Adjusted`[[1]])
anovaba <- cbind(Source = trimws(rownames(anovaba)), anovaba)
}
anovaba$sig <- ifelse(anovaba$Pr..F. <= 0.01, "**",
ifelse(anovaba$Pr..F. <= 0.05, "*", "ns"))
colnames(anovaba) <- c("Source", "Df", "Sum Sq", "Mean Sq",
"F value", "Pr(>F)", " ")
anovaba$Df <- as.character(anovaba$Df)
anovaba[, c("Sum Sq", "Mean Sq")] <-
lapply(anovaba[, c("Sum Sq", "Mean Sq")], round.conditional,
digits = round.digits)
anovaba[, c("F value", "Pr(>F)")] <-
lapply(anovaba[, c("F value", "Pr(>F)")], round.conditional,
digits = max(round.digits, 3))
nsindex <- which(anovaba[, 7] == "ns")
anovaba <- autofit(regulartable(anovaba))
if (!is.null(nsindex)) {
anovaba <- compose(anovaba, part = "body", i = nsindex, j = 7,
value = as_paragraph(as_sup("ns")))
}
anovaba <- align(anovaba, j = 2:6, align = "right", part = "all")
anovaba <- bold(anovaba, part = "header")
augreport <- body_add_flextable(augreport, anovaba)
augreport <- body_add_fpar(augreport,
value = fpar(ftext("ns", suppar),
ftext(" P > 0.05; * P <= 0.05; ** P <= 0.01")))
if (!is.null(anova_warn)) {
for (i in seq_along(anova_warn)) {
augreport <- body_add_par(augreport, value = anova_warn[i],
style = "Warning")
}
}
# Std. Errors
augreport <- body_add_par(augreport,
value = "Standard Errors and Critical Differences",
style = "heading 1")
se <- aug$`Std. Errors`
se <- cbind(Comparison = row.names(se), se)
se <- dplyr::mutate_if(se, is.numeric, round.conditional,
digits = round.digits)
se <- autofit(regulartable(se))
se <- align(se, j = 2:3, align = "right", part = "all")
se <- bold(se, part = "header")
augreport <- body_add_flextable(augreport, se)
# Overall adjusted mean
augreport <- body_add_par(augreport, value = "Overall Adjusted Mean",
style = "heading 1")
augreport <- body_add_par(augreport,
value = as.character(round.conditional(aug$`Overall adjusted mean`,
digits = round.digits)),
style = "Normal")
# Coefficient of variation
augreport <- body_add_par(augreport, value = "Coefficient of Variation",
style = "heading 1")
augreport <- body_add_par(augreport,
value = as.character(round.conditional(aug$CV,
digits = round.digits)),
style = "Normal")
# Means
augreport <- body_add_par(augreport, value = "Means", style = "heading 1")
Means <- aug$Means
Means[, c("Means", "SE", "Min", "Max", "Adjusted Means")] <-
lapply(Means[, c("Means", "SE", "Min", "Max", "Adjusted Means")],
round.conditional, digits = round.digits)
if (any(grepl(wstring2, aug$warnings))) {
wstring2_mod <- trimws(unlist(strsplit(aug$warnings[grepl(wstring2,
aug$warnings)],
"\n")))
neg_trts <- trimws(unlist(strsplit(wstring2_mod[2], ",")))
neg_index <- which(Means$Treatment %in% neg_trts)
Means$x <- ""
Means[neg_index, ]$x <- "\u2020"
colnames(Means) <- c("Treatment", "Block", "Means", "SE", "r", "Min",
"Max", "Adjusted Means", " ")
}
Means <- autofit(regulartable(Means))
Means <- align(Means, j = 2:8, align = "right", part = "all")
Means <- bold(Means, part = "header")
augreport <- body_add_flextable(augreport, Means)
if (any(grepl(wstring2, aug$warnings))) {
neg_msg <- gsub(" were generated for the following treatment\\(s\\)", "",
wstring2_mod[1])
if (!is.na(wstring2_mod[3])) {
neg_msg <- paste(neg_msg, " (",
stri_trans_totitle(gsub("They were ", "",
wstring2_mod[3]),
type = "sentence"),
")", sep = "")
}
neg_msg <- paste("\u2020 ", neg_msg, ".", sep = "")
augreport <- body_add_par(augreport, value = neg_msg, style = "Normal")
}
# Freq dist
augreport <- body_add_par(augreport, value = "Frequency Distribution",
style = "heading 1")
src <- tempfile(fileext = ".png")
png(filename = src, width = 6, height = 4, units = 'in', res = 300)
fqwarn <- NULL
withCallingHandlers({
plot(freqdist.augmentedRCBD(aug, xlab = "", check.col = check.col))
}, warning = function(w) {
fqwarn <<- append(fqwarn, cli::ansi_strip(w$message))
invokeRestart("muffleWarning")
})
dev.off()
augreport <- body_add_img(augreport, src = src, width = 6, height = 4)
rm(src)
if (!is.null(fqwarn)) {
augreport <- body_add_par(augreport, value = "\r\n", style = "Normal")
for (i in seq_along(fqwarn)) {
augreport <- body_add_par(augreport, value = fqwarn[i],
style = "Warning")
}
}
# Desc stat
augreport <- body_add_par(augreport, value = "Descriptive Statistics",
style = "heading 1")
descout <- data.frame(describe.augmentedRCBD(aug))[1, ]
descout$Skewness.p.value. <- ifelse(descout$Skewness.p.value. <= 0.01, "**",
ifelse(descout$Skewness.p.value. <= 0.05,
"*", "ns"))
descout$Kurtosis.p.value. <- ifelse(descout$Kurtosis.p.value. <= 0.01, "**",
ifelse(descout$Kurtosis.p.value. <= 0.05,
"*", "ns"))
desc <- c("Mean", "Std.Error", "Std.Deviation", "Min",
"Max", "Skewness.statistic.", "Kurtosis.statistic.")
descout[, desc] <- apply(descout[, desc], MARGIN = 2,
FUN = round.conditional, digits = round.digits)
colnames(descout) <- c("Count", "Mean", "Std.Error", "Std.Deviation",
"Min", "Max", "Skewness", "Skewness_sig", "Kurtosis",
"Kurtosis_sig")
descout <- rbind(descout[, c("Count", "Mean", "Std.Error", "Std.Deviation",
"Min", "Max", "Skewness", "Kurtosis")],
c(rep("", 6),
unlist(descout[,
c("Skewness_sig", "Kurtosis_sig")])))
descout <- data.frame(t(descout))
descout <- cbind(Statistic = rownames(descout), descout)
rownames(descout) <- NULL
colnames(descout) <- c("Statistic", "Value", " ")
nsindex <- which(descout[, 3] == "ns")
descout <- autofit(regulartable(descout))
if (!is.null(nsindex)) {
descout <- compose(descout, part = "body", i = nsindex, j = 3,
value = as_paragraph(as_sup("ns")))
}
descout <- align(descout, j = 2, align = "right", part = "all")
descout <- align(descout, j = 3, align = "left", part = "all")
descout <- bold(descout, part = "header")
augreport <- body_add_flextable(augreport, descout)
augreport <- body_add_fpar(augreport,
value = fpar(ftext("ns", suppar),
ftext(" P > 0.05; * P <= 0.05; ** P <= 0.01")))
# GVA
augreport <- body_add_par(augreport, value = "Genetic Variability Analysis",
style = "heading 1")
gvaout <- gva.augmentedRCBD(aug, k = k)
gvawarn <- NULL
withCallingHandlers({
gvaout <- data.frame(gva.augmentedRCBD(aug, k = k))
}, warning = function(w) {
gvawarn <<- append(gvawarn, cli::ansi_strip(w$message))
invokeRestart("muffleWarning")
})
gvaout <- data.frame(gvaout)
gvaout <- dplyr::mutate_if(gvaout, is.numeric, round.conditional,
digits = round.digits)
gvaout <- data.frame(t(gvaout))
gvaout <- cbind(Statistic = rownames(gvaout), gvaout)
rownames(gvaout) <- NULL
gvaout$x <- c(rep("", 11), rep("*", 3))
gvaout$x <- ifelse(is.na(gvaout$t.gvaout.), "", gvaout$x)
colnames(gvaout) <- c("Statistic", "Value", " ")
gvaout <- autofit(regulartable(gvaout))
gvaout <- align(gvaout, j = 2, align = "right", part = "all")
gvaout <- align(gvaout, j = 3, align = "left", part = "all")
gvaout <- bold(gvaout, part = "header")
augreport <- body_add_flextable(augreport, gvaout)
augreport <- body_add_par(augreport, value = paste("* k =", k))
if (!is.null(gvawarn)) {
augreport <- body_add_par(augreport, value = "\r\n", style = "Normal")
for (i in seq_along(gvawarn)) {
augreport <- body_add_par(augreport, value = gvawarn[i],
style = "Warning")
}
}
# Comparisons
if (!is.null(aug$Comparisons)) {
augreport <- body_add_par(augreport, value = "Comparisons",
style = "heading 1")
augreport <- body_add_par(augreport,
value = paste("Comparison method:",
aug$`Comparison method`),
style = "Normal")
cmp <- aug$Comparisons
cmp[, c("estimate", "SE")] <-
lapply(cmp[, c("estimate", "SE")],
round.conditional, digits = round.digits)
cmp[, c("t.ratio", "p.value")] <-
lapply(cmp[, c("t.ratio", "p.value")],
round.conditional, digits = max(round.digits, 3))
cmp <- autofit(regulartable(cmp))
cmp <- align(cmp, j = 2:6, align = "right", part = "all")
cmp <- bold(cmp, part = "header")
augreport <- body_add_flextable(augreport, cmp)
augreport <- body_add_par(augreport,
value = "* P \u2264 0.05; ** P \u2264 0.01",
style = "Normal")
}
# Groups
if (!is.null(aug$Groups)) {
augreport <- body_add_par(augreport, value = "Groups",
style = "heading 1")
augreport <- body_add_par(augreport,
value = paste("Comparison method:",
aug$`Comparison method`),
style = "Normal")
gps <- aug$Groups
gps[, c("Adjusted Means", "SE", "lower.CL", "upper.CL")] <-
lapply(gps[, c("Adjusted Means", "SE", "lower.CL", "upper.CL")],
round.conditional, digits = round.digits)
gps <- autofit(regulartable(gps))
gps <- align(gps, j = 2:5, align = "right", part = "all")
gps <- bold(gps, part = "header")
augreport <- body_add_flextable(augreport, gps)
}
# Warnings
if (!all(unlist(lapply(list(aug$warnings, fqwarn, gvawarn), is.null)))) {
augreport <- body_add_par(augreport, value = "Warnings",
style = "heading 1")
if (!is.null(aug$warnings)) {
augreport <- body_add_par(augreport,
value = "Model",
style = "heading 2")
warn_mod <- trimws(unlist(strsplit(aug$warnings, "\n")))
for (i in seq_along(warn_mod)) {
augreport <- body_add_par(augreport,
value = warn_mod[i],
style = "Code")
}
}
if (!is.null(fqwarn)) {
augreport <- body_add_par(augreport,
value = "Frequency Distribution",
style = "heading 2")
for (i in seq_along(fqwarn)) {
augreport <- body_add_par(augreport, value = fqwarn[i],
style = "Code")
}
}
if (!is.null(gvawarn)) {
augreport <- body_add_par(augreport,
value = "Genetic Variablity Analysis",
style = "heading 2")
for (i in seq_along(gvawarn)) {
augreport <- body_add_par(augreport, value = gvawarn[i],
style = "Code")
}
}
}
augreport <- body_add_par(augreport, value = "Citation Info",
style = "heading 1")
citout <- capture.output(citation("augmentedRCBD"))
citlist <- wlist2blist(citout,
fp_p = fp_par(padding.bottom = 2,
word_style = "Code"))
augreport <- body_add_blocks(augreport, blocks = citlist)
print(augreport, target = target)
}
if (file.type == "excel") {
if (!grepl(x = target, pattern = "\\.(xlsx)$", ignore.case = TRUE)) {
stop(target, " should have '.xlsx' extension.")
}
# Create workbook
wb <- createWorkbook()
modifyBaseFont(wb, fontSize = 10, fontName = "Arial")
hs <- createStyle(halign = "left", valign = "bottom")
num.base <- paste("0.", paste(rep(0, round.digits), collapse = ""), sep = "")
numstyle <- createStyle(numFmt = num.base)
num.base.p <- paste("0.", paste(rep(0, max(round.digits, 3)),
collapse = ""), sep = "")
numstyle.p <- createStyle(numFmt = num.base.p)
ssstyle <- createStyle(numFmt = paste(num.base, '"*"'))
dsstyle <- createStyle(numFmt = paste(num.base, '"**"'))
nsstyle <- createStyle(numFmt = paste(num.base, '"\u207f\u02e2"'))
csstyle <- createStyle(numFmt = paste(num.base, '"\u2020"'))
numstyle2 <- createStyle(numFmt = paste(num.base, '"\u00A0""\u00A0"'))
# Index
index <- c("Details", "ANOVA, Treatment Adjusted", "ANOVA, Block Adjusted",
"SEs and CDs", "Overall Adjusted Mean", "Coefficient of Variation",
"Means", "Frequency Distribution", "Descriptive Statistics",
"Genetic Variability Analysis")
if (!is.null(aug$Comparisons)) {
index <- c(index, "Comparisons")
}
if (!is.null(aug$Groups)) {
index <- c(index, "Groups")
}
index <- c(index, "Warnings")
index <- data.frame(`Sl.No` = seq_along(index), Sheets = index)
addWorksheet(wb, sheetName = "Index", gridLines = FALSE)
insertImage(wb, sheet = "Index",
file = system.file("extdata", "augmentedRCBD.png",
package = "augmentedRCBD"),
startCol = "A", startRow = 2,
width = 1, height = 1.1)
writeData(wb, sheet = "Index",
x = "https://aravind-j.github.io/augmentedRCBD",
startCol = "C", startRow = 4, borders = "none")
writeData(wb, sheet = "Index",
x = "https://github.com/aravind-j/augmentedRCBD",
startCol = "C", startRow = 5, borders = "none")
writeData(wb, sheet = "Index",
x = "https://CRAN.R-project.org/package=augmentedRCBD",
startCol = "C", startRow = 6, borders = "none")
writeDataTable(wb, sheet = "Index", x = index,
startCol = "B", startRow = 9, colNames = TRUE, rowNames = FALSE,
headerStyle = hs, tableStyle = "TableStyleLight1",
withFilter = FALSE, bandedRows = FALSE)
addStyle(wb, sheet = "Index", style = createStyle(halign = "right"),
rows = 9, cols = 2, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "Index", cols = 1:3, widths = "auto")
citout <- capture.output(citation("augmentedRCBD"))
writeData(wb, sheet = "Index", x = citout,
startCol = "B", startRow = 25, borders = "none")
setColWidths(wb, sheet = "Index", cols = 2, widths = 5)
# Details
Details <- t(data.frame(`Number of blocks` = aug$Details$`Number of blocks`,
`Number of treatments` = aug$Details$`Number of treatments`,
`Number of check treatments` = aug$Details$`Number of check treatments`,
`Number of test treatments` = aug$Details$`Number of test treatments`,
`Check treatments` = paste(aug$Details$`Check treatments`,
collapse = ", ")))
Details <- data.frame(Details)
Details <- cbind(gsub("\\.", " ", rownames(Details)), Details)
colnames(Details) <- c("Item", "Details")
addWorksheet(wb, sheetName = "Details", gridLines = FALSE)
writeDataTable(wb, sheet = "Details", x = Details,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
setColWidths(wb, sheet = "Details", cols = 1:ncol(Details), widths = "auto")
if (any(grepl(wstring1, aug$warnings))) {
dups <- aug$Means[!(aug$Means$Treatment %in% checks), ]$Treatment
dups <- dups[duplicated(dups)]
dups <- aug$Means[aug$Means$Treatment %in% dups, c("Treatment", "Block")]
rownames(dups) <- NULL
writeData(wb, sheet = "Details", xy = c("A", 8),
x = "Following test treatments are replicated.",
borders = "none")
addStyle(wb, sheet = "Details",
style = createStyle(fontColour = "#C00000"),
rows = 8, cols = 1, stack = FALSE, gridExpand = TRUE)
writeDataTable(wb, sheet = "Details", x = dups, xy = c("A", 10),
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
}
setColWidths(wb, sheet = "Details", cols = 1,
widths = max(nchar(Details$Item)) + 5)
anova_warn <- NULL
if (any(!grepl(paste(c(wstring1, wstring2), collapse = "|"),
aug$warnings))) {
anova_warn <- aug$warnings[!grepl(paste(c(wstring1, wstring2),
collapse = "|"),
aug$warnings)]
}
# ANOVA, TA
if (is.data.frame(aug$`ANOVA, Treatment Adjusted`)){
anovata <- aug$`ANOVA, Treatment Adjusted`
} else {
anovata <- data.frame(aug$`ANOVA, Treatment Adjusted`[[1]])
anovata <- cbind(Source = trimws(rownames(anovata)), anovata)
}
anovata$sig <- ifelse(anovata$Pr..F. <= 0.01, "**",
ifelse(anovata$Pr..F. <= 0.05, "*", "\u207f\u02e2"))
colnames(anovata) <- c("Source", "Df", "Sum Sq", "Mean Sq",
"F value", "Pr(>F)", " ")
addWorksheet(wb, sheetName = "ANOVA, Treatment Adjusted", gridLines = FALSE)
writeDataTable(wb, sheet = "ANOVA, Treatment Adjusted", x = anovata,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "ANOVA, Treatment Adjusted", style = numstyle,
rows = 2:6, cols = 3:4, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "ANOVA, Treatment Adjusted", style = numstyle.p,
rows = 2:6, cols = 5:6, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "ANOVA, Treatment Adjusted",
style = createStyle(halign = "right"),
rows = 1, cols = 2:6, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "ANOVA, Treatment Adjusted",
cols = 1:ncol(anovata), widths = "auto")
writeData(wb, sheet = "ANOVA, Treatment Adjusted",
xy = c("A", 7),
x = "\u207f\u02e2 P > 0.05; * P <= 0.05; ** P <= 0.01",
borders = "none")
setColWidths(wb, sheet = "ANOVA, Treatment Adjusted", cols = 1,
widths = max(nchar(anovata$Source)) + 5)
if (!is.null(anova_warn)) {
writeData(wb, sheet = "ANOVA, Treatment Adjusted",
xy = c("A", 9), x = anova_warn, borders = "none")
}
# ANOVA, BA
if (is.data.frame(aug$`ANOVA, Block Adjusted`)){
anovaba <- aug$`ANOVA, Block Adjusted`
} else {
anovaba <- data.frame(aug$`ANOVA, Block Adjusted`[[1]])
anovaba <- cbind(Source = trimws(rownames(anovaba)), anovaba)
}
anovaba$sig <- ifelse(anovaba$Pr..F. <= 0.01, "**",
ifelse(anovaba$Pr..F. <= 0.05, "*", "\u207f\u02e2"))
colnames(anovaba) <- c("Source", "Df", "Sum Sq", "Mean Sq",
"F value", "Pr(>F)", " ")
addWorksheet(wb, sheetName = "ANOVA, Block Adjusted", gridLines = FALSE)
writeDataTable(wb, sheet = "ANOVA, Block Adjusted", x = anovaba,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "ANOVA, Block Adjusted", style = numstyle,
rows = 2:7, cols = 3:4, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "ANOVA, Block Adjusted", style = numstyle,
rows = 2:7, cols = 5:6, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "ANOVA, Block Adjusted",
style = createStyle(halign = "right"),
rows = 1, cols = 2:6, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "ANOVA, Block Adjusted",
cols = 1:ncol(anovaba), widths = "auto")
writeData(wb, sheet = "ANOVA, Block Adjusted",
xy = c("A", 8),
x = "\u207f\u02e2 P > 0.05; * P <= 0.05; ** P <= 0.01",
borders = "none")
setColWidths(wb, sheet = "ANOVA, Block Adjusted", cols = 1,
widths = max(nchar(anovata$Source)) + 5)
if (!is.null(anova_warn)) {
writeData(wb, sheet = "ANOVA, Block Adjusted",
xy = c("A", 10), x = anova_warn, borders = "none")
}
# Std. Errors
se <- aug$`Std. Errors`
se <- cbind(Comparison = row.names(se), se)
addWorksheet(wb, sheetName = "SEs and CDs", gridLines = FALSE)
writeDataTable(wb, sheet = "SEs and CDs", x = se,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "SEs and CDs", style = numstyle,
rows = 2:5, cols = 2:3, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "SEs and CDs", style = createStyle(halign = "right"),
rows = 1, cols = 2:3, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "SEs and CDs",
cols = 1:ncol(se), widths = "auto")
# Overall adjusted mean
addWorksheet(wb, sheetName = "Overall Adjusted Mean", gridLines = FALSE)
writeData(wb, sheet = "Overall Adjusted Mean",
x = aug$`Overall adjusted mean`,
startCol = "A", startRow = 1, borders = "none")
addStyle(wb, sheet = "Overall Adjusted Mean", style = numstyle,
rows = 1, cols = 1, stack = FALSE)
# Coefficient of variation
addWorksheet(wb, sheetName = "Coefficient of Variation", gridLines = FALSE)
writeData(wb, sheet = "Coefficient of Variation", x = aug$CV,
startCol = "A", startRow = 1, borders = "none")
addStyle(wb, sheet = "Coefficient of Variation", style = numstyle,
rows = 1, cols = 1, stack = FALSE)
# Means
Means <- aug$Means
addWorksheet(wb, sheetName = "Means", gridLines = FALSE)
writeDataTable(wb, sheet = "Means", x = Means,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "Means", style = numstyle,
rows = 2:(nrow(Means) + 1), cols = c(3:4, 6:8),
stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Means", style = createStyle(halign = "right"),
rows = 1, cols = 3:8, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "Means",
cols = 1:ncol(Means), widths = "auto")
if (any(grepl(wstring2, aug$warnings))) {
wstring2_mod <- trimws(unlist(strsplit(aug$warnings[grepl(wstring2,
aug$warnings)],
"\n")))
neg_trts <- trimws(unlist(strsplit(wstring2_mod[2], ",")))
neg_index <- which(Means$Treatment %in% neg_trts)
neg_index2 <- which(!(Means$Treatment %in% neg_trts))
addStyle(wb, sheet = "Means", style = csstyle,
rows = neg_index + 1,
cols = 8, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Means", style = numstyle2,
rows = neg_index2 + 1,
cols = 8, stack = FALSE, gridExpand = TRUE)
neg_msg <- gsub(" were generated for the following treatment\\(s\\)", "",
wstring2_mod[1])
if (!is.na(wstring2_mod[3])) {
neg_msg <- paste(neg_msg, " (",
stri_trans_totitle(gsub("They were ", "",
wstring2_mod[3]),
type = "sentence"),
")", sep = "")
}
neg_msg <- paste("\u2020 ", neg_msg, ".", sep = "")
writeData(wb, sheet = "Means", x = neg_msg, xy = c("A", nrow(Means) + 2),
borders = "none")
}
setColWidths(wb, sheet = "Means", cols = 1,
widths = max(nchar(Means$Treatment), 9) + 7)
setColWidths(wb, sheet = "Means", cols = 6,
widths = max(nchar(Means$Min), 5) + 2)
setColWidths(wb, sheet = "Means", cols = 7,
widths = max(nchar(Means$Max), 5) + 2)
# Freq dist
addWorksheet(wb, sheetName = "Frequency Distribution", gridLines = FALSE)
fqwarn <- NULL
withCallingHandlers({
plot(freqdist.augmentedRCBD(aug, xlab = "", check.col = check.col))
}, warning = function(w) {
fqwarn <<- append(fqwarn, cli::ansi_strip(w$message))
invokeRestart("muffleWarning")
})
insertPlot(wb, sheet = "Frequency Distribution",
xy = c("A", 2))
dev.off()
if (!is.null(fqwarn)) {
writeData(wb, sheet = "Frequency Distribution", xy = c("A", 25),
x = fqwarn, borders = "none")
addStyle(wb, sheet = "Frequency Distribution",
style = createStyle(fontColour = "#C00000"),
rows = 25:(25 + length(fqwarn)), cols = 1,
stack = FALSE, gridExpand = TRUE)
}
# Desc stat
descout <- data.frame(describe.augmentedRCBD(aug))[1, ]
descout_sub <- descout[, c("Skewness.p.value.", "Kurtosis.p.value.")]
descout <- descout[, c("Count", "Mean", "Std.Error", "Std.Deviation",
"Min", "Max", "Skewness.statistic.",
"Kurtosis.statistic.")]
colnames(descout) <- gsub("\\.statistic\\.", "", colnames(descout))
descout <- data.frame(t(descout))
descout <- cbind(Statistic = rownames(descout), descout)
rownames(descout) <- NULL
colnames(descout) <- c("Statistic", "Value")
addWorksheet(wb, sheetName = "Descriptive Statistics", gridLines = FALSE)
writeDataTable(wb, sheet = "Descriptive Statistics", x = descout,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "Descriptive Statistics", style = numstyle,
rows = 3:7, cols = 2, stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Descriptive Statistics",
style = if(descout_sub$Skewness.p.value. <= 0.01) {
dsstyle } else {
if (descout_sub$Skewness.p.value. <= 0.05) {
ssstyle
} else {
nsstyle
}
},
rows = 8, cols = 2, stack = FALSE)
addStyle(wb, sheet = "Descriptive Statistics",
style = if(descout_sub$Kurtosis.p.value. <= 0.01) {
dsstyle } else {
if (descout_sub$Kurtosis.p.value. <= 0.05) {
ssstyle
} else {
nsstyle
}
},
rows = 9, cols = 2, stack = FALSE)
addStyle(wb, sheet = "Descriptive Statistics",
style = createStyle(halign = "right"),
rows = 1, cols = 2, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "Descriptive Statistics",
cols = 1:ncol(descout), widths = "auto")
writeData(wb, sheet = "Descriptive Statistics", xy = c("A", 10),
x = "\u207f\u02e2 P > 0.05; * P <= 0.05; ** P <= 0.01",
borders = "none")
setColWidths(wb, sheet = "Descriptive Statistics", cols = 1,
widths = max(nchar(descout$Statistic)) + 5)
# GVA
gvawarn <- NULL
withCallingHandlers({
gvaout <- data.frame(gva.augmentedRCBD(aug, k = k))
}, warning = function(w) {
gvawarn <<- append(gvawarn, cli::ansi_strip(w$message))
invokeRestart("muffleWarning")
})
gvaout <- data.frame(t(gvaout))
gvaout <- cbind(Statistic = rownames(gvaout), gvaout)
rownames(gvaout) <- NULL
gvaout$x <- c(rep("", 11), rep("*", 3))
gvaout$x <- ifelse(is.na(gvaout$t.gvaout.), "", gvaout$x)
colnames(gvaout) <- c("Statistic", "Value", " ")
stat_cat <- c("GCV.category", "PCV.category", "hBS.category", "GAM.category")
gvaout_sub <- gvaout[gvaout$Statistic %in% stat_cat, ]
gvaout[gvaout$Statistic %in% stat_cat, ]$Value <- "0"
gvaout$Value <- as.numeric(gvaout$Value)
addWorksheet(wb, sheetName = "Genetic Variability Analysis",
gridLines = FALSE)
writeDataTable(wb, sheet = "Genetic Variability Analysis", x = gvaout,
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", withFilter = FALSE,
bandedRows = FALSE)
addStyle(wb, sheet = "Genetic Variability Analysis", style = numstyle,
rows = c(2:6, 8, 10:11, 13:14), cols = 2,
stack = FALSE, gridExpand = TRUE)
writeData(wb, sheet = "Genetic Variability Analysis",
x = gvaout_sub[gvaout_sub == "GCV.category", ]$Value,
xy = c("B", 7), borders = "none")
writeData(wb, sheet = "Genetic Variability Analysis",
x = gvaout_sub[gvaout_sub == "PCV.category", ]$Value,
xy = c("B", 9), borders = "none")
writeData(wb, sheet = "Genetic Variability Analysis",
x = gvaout_sub[gvaout_sub == "hBS.category", ]$Value,
xy = c("B", 12), borders = "none")
writeData(wb, sheet = "Genetic Variability Analysis",
x = gvaout_sub[gvaout_sub == "GAM.category", ]$Value,
xy = c("B", 15), borders = "none")
addStyle(wb, sheet = "Genetic Variability Analysis",
style = createStyle(halign = "right"),
rows = 1:15, cols = 2, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "Genetic Variability Analysis",
cols = 1:ncol(gvaout), widths = "auto")
writeData(wb, sheet = "Genetic Variability Analysis",
x = paste("* k =", k),
xy = c("A", 16), borders = "none")
if (!is.null(gvawarn)) {
writeData(wb, sheet = "Genetic Variability Analysis", xy = c("A", 18),
x = gvawarn, borders = "none")
addStyle(wb, sheet = "Genetic Variability Analysis",
style = createStyle(fontColour = "#C00000"),
rows = 18:(18 + length(gvawarn) - 1), cols = 1,
stack = FALSE, gridExpand = TRUE)
}
setColWidths(wb, sheet = "Genetic Variability Analysis", cols = 1,
widths = max(nchar(gvaout$Statistic) + 7))
# Comparisons
if (!is.null(aug$Comparisons)) {
cmp <- aug$Comparisons
addWorksheet(wb, sheetName = "Comparisons",
gridLines = FALSE)
writeData(wb, sheet = "Comparisons", xy = c("A", 1),
x = paste("Comparison method:",
aug$`Comparison method`), borders = "none")
writeDataTable(wb, sheet = "Comparisons",
x = cmp, xy = c("A", 2),
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", bandedRows = FALSE,
withFilter = FALSE)
addStyle(wb, sheet = "Comparisons", style = numstyle,
rows = 3:(nrow(cmp) + 2), cols = c(2:3, 5:6),
stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Comparisons", style = numstyle.p,
rows = 3:(nrow(cmp) + 2), cols = c(5:6),
stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Comparisons", style = createStyle(halign = "right"),
rows = 2, cols = 2:6, stack = TRUE, gridExpand = TRUE)
writeData(wb, sheet = "Comparisons", xy = c("A", nrow(cmp) + 3),
x = "* P \u2264 0.05; ** P \u2264 0.01", borders = "none")
setColWidths(wb, sheet = "Comparisons", cols = 1,
widths = max(nchar(cmp$contrast), 8) + 5)
}
# Groups
if (!is.null(aug$Groups)) {
addWorksheet(wb, sheetName = "Groups",
gridLines = FALSE)
writeData(wb, sheet = "Groups", xy = c("A", 1),
x = paste("Comparison method:",
aug$`Comparison method`), borders = "none")
gps <- aug$Groups
writeDataTable(wb, sheet = "Groups", x = gps, xy = c("A", 2),
colNames = TRUE, rowNames = FALSE, headerStyle = hs,
tableStyle = "TableStyleLight1", bandedRows = FALSE,
withFilter = FALSE)
addStyle(wb, sheet = "Groups", style = numstyle,
rows = 3:(nrow(gps) + 2), cols = c(2:3, 5:6),
stack = FALSE, gridExpand = TRUE)
addStyle(wb, sheet = "Groups", style = createStyle(halign = "right"),
rows = 2, cols = 2:6, stack = TRUE, gridExpand = TRUE)
setColWidths(wb, sheet = "Groups", cols = 1,
widths = max(nchar(as.character(gps$Treatment)), 9) + 3)
setColWidths(wb, sheet = "Groups", cols = 2,
widths = max(nchar(as.character(gps$`Adjusted Means`)),
14) + 3)
}
# Warnings
if (!all( unlist(lapply(list(aug$warnings, fqwarn, gvawarn), is.null)))) {
addWorksheet(wb, sheetName = "Warnings", gridLines = FALSE)
row1 <- 1
if (!is.null(aug$warnings)) {
warn_mod <- trimws(unlist(strsplit(aug$warnings, "\n")))
writeData(wb, sheet = "Warnings", x = "Model",
startCol = "A", startRow = row1, borders = "none")
writeData(wb, sheet = "Warnings",
x = warn_mod,
startCol = "A", row1 + 1, borders = "none")
addStyle(wb, sheet = "Warnings",
style = createStyle(textDecoration = "bold"),
rows = row1, cols = 1, stack = FALSE, gridExpand = TRUE)
row1 <- row1 + 2 + length(warn_mod)
}
if (!is.null(fqwarn)) {
writeData(wb, sheet = "Warnings", x = "Frequency Distribution",
startCol = "A", startRow = row1, borders = "none")
writeData(wb, sheet = "Warnings",
x = fqwarn,
startCol = "A", row1 + 1, borders = "none")
addStyle(wb, sheet = "Warnings",
style = createStyle(textDecoration = "bold"),
rows = row1, cols = 1, stack = FALSE, gridExpand = TRUE)
row1 <- row1 + 2 + length(fqwarn)
}
if (!is.null(gvawarn)) {
writeData(wb, sheet = "Warnings", x = "Genetic Variablity Analysis",
startCol = "A", startRow = row1, borders = "none")
writeData(wb, sheet = "Warnings",
x = gvawarn,
startCol = "A", row1 + 1, borders = "none")
addStyle(wb, sheet = "Warnings",
style = createStyle(textDecoration = "bold"),
rows = row1, cols = 1, stack = FALSE, gridExpand = TRUE)
row1 <- row1 + 2 + length(gvawarn)
}
}
saveWorkbook(wb = wb, file = target, overwrite = TRUE)
}
message(paste("File created at", target))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.