R/oq.R
In dbosak01/sassy: Makes 'R' Easier for Everyone
Defines functions
check_procs
check_reporter
check_libr
check_fmtr
check_logr
check_common
check_packages
run_oq
Documented in
run_oq
# Needed to get command check to pass without notes
# Complaining about undeclared variables that are actually non-standard eval
utils::globalVariables(c("hello", "goodbye", "x", "tst", "mpg"))
# Operational Qualification -----------------------------------------------
#' @title Generates an Operational Qualification Report
#' @description The \code{run_oq} function executes an
#' operational qualification (OQ)
#' on the currently installed \strong{sassy} packages and generates a report
#' on the results. The OQ ensures that the \strong{sassy} packages are
#' installed and working
#' as expected. The results will be placed in the supplied location.
#' @details
#' The Operation Qualification works by executing a representative set of
#' functions from each \strong{sassy} package, and comparing the
#' results against expected values. Here is a brief description of the
#' operations performed on each package:
#' \itemize{
#' \item{\strong{logr}: A sample log is produced and checked for existence.
#' This test confirms the following functions: \code{log_open}, \code{log_print},
#' and \code{log_close}.
#' }
#' \item{\strong{fmtr}: The basic operations of the package are executed
#' and compared against expected output: \code{fapply}, \code{fdata},
#' \code{value}, \code{condition}, \code{write.fcat}, and \code{read.fcat}.
#' }
#' \item{\strong{libr}: The procedure verifies that the fundamental operations
#' of the package are working properly without errors: \code{libname},
#' \code{lib_add}, \code{lib_remove}, \code{dictionary}, and \code{datastep}.
#' }
#' \item{\strong{reporter}: The reporter package is tested by producing
#' sample reports in each of the available output types: TXT, HTML,
#' RTF, PDF, and DOCX. This method tests almost all of the sub-functions
#' of the package.
#' }
#' \item{\strong{common}: The following representative functions are
#' run and tested for errors and valid return values: \code{v},
#' \code{sort}, \code{labels},
#' \code{roundup}, \code{Sys.path}, \code{find.names},
#' and \code{copy.attributes}.
#' }
#' \item{\strong{procs}: All the major functions of the package are
#' executed and tested against expected results: \code{proc_freq},
#' \code{proc_means}, \code{proc_transpose}, \code{proc_sort}, and
#' \code{proc_print}.
#' }
#' }
#'
#' @param location The path to the desired output directory. The IQ
#' reports and any other associated files will be placed in this directory.
#' Location should be specified as a directory only. The file names
#' will be generated by the function.
#' @return The path to the output directory. This directory will
#' contain subdirectories with the output reports, logs, and other files
#' produced by the Operation Qualification. At the top level, the directory
#' will contain a PDF report showing a summary of the results of the OQ. After
#' the function is run, review this report to ensure that all tests passed.
#' @examples
#' # Create a temp directory
#' tmp <- tempdir()
#'
#' # Uncomment to Run the Operational Qualification
#' # run_oq(tmp)
#' @export
run_oq <- function(location) {
if (!dir.exists(location)) {
dir.create(opth, recursive = TRUE)
}
# Create needed folders
dpth <- file.path(location, "data")
if (!dir.exists(dpth))
dir.create(dpth)
opth <- file.path(location, "output")
if (!dir.exists(opth))
dir.create(opth)
lpth <- file.path(location, "log")
if (!dir.exists(lpth))
dir.create(lpth)
# Initialize output data frame
ret <- data.frame(Category = "sassy",
Description = "System Initialization",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check that all sassy packages exist
ret <- rbind(ret, check_packages())
# Checks for logr package
ret <- rbind(ret, check_logr(opth))
# Now that log is tested and packages exist, create run log
lg <- log_open(file.path(lpth, "runOQ.log"), logdir = FALSE,
show_notes = FALSE, autolog = TRUE)
sep("Initialization results")
put(ret)
if (all(ret$Pass == TRUE)) {
sep("Package Checks")
sep("Checks for common package")
ret <- rbind(ret, check_common())
sep("Checks for fmtr package")
ret <- rbind(ret, check_fmtr(opth))
sep("Checks for libr package")
ret <- rbind(ret, check_libr(dpth))
sep("Checks for reporter package")
ret <- rbind(ret, check_reporter(opth))
sep("Checks for procs package")
ret <- rbind(ret, check_procs(opth))
} else {
put("OQ run stopped due to initalization failure.")
}
sep("Preparing Report")
put("Complete Results: ")
put(ret)
# Print report
ttls <- c("Operational Qualification Results Report",
"SASSY System")
pth <- file.path(location, "sassyOQ-" %p% Sys.Date())
put("Printing report")
put("Report path: " %p% pth)
res <- print_report(pth, ret, ttls)
view_report(ret, ttls)
log_close()
return(res)
}
# OQ Subroutines ----------------------------------------------------------
check_packages <- function() {
tmplt <- data.frame(Category = "sassy",
Description = "System Initialization",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for logr package
res <- system.file(package = "logr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for logr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "logr package not found."
}
ret <- tmp
# Check for fmtr package
res <- system.file(package = "fmtr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for fmtr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "fmtr package not found."
}
ret <- rbind(ret, tmp)
# Check for common package
res <- system.file(package = "common")
tmp <- tmplt
tmp[1, "Description"] <- "Check for common package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "common package not found."
}
ret <- rbind(ret, tmp)
# Check for libr package
res <- system.file(package = "libr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for libr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libr package not found."
}
ret <- rbind(ret, tmp)
# Check for reporter package
res <- system.file(package = "reporter")
tmp <- tmplt
tmp[1, "Description"] <- "Check for reporter package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "reporter package not found."
}
ret <- rbind(ret, tmp)
# Check for procs package
res <- system.file(package = "procs")
tmp <- tmplt
tmp[1, "Description"] <- "Check for procs package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "procs package not found."
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import common
#' @import datasets
check_common <- function() {
tmplt <- data.frame(Category = "common",
Description = "Common test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for v() function
res <- v(hello, goodbye)
tmp <- tmplt
tmp[1, "Description"] <- "v() function works as expected."
if (any(res != c("hello", "goodbye"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("v() function check failed.")
put(res)
} else {
put("v() function check passed.")
}
ret <- tmp
# Check for sort() function
res <- sort(datasets::mtcars[1:5, ], by = 'mpg')
tmp <- tmplt
tmp[1, "Description"] <- "sort() function works as expected."
if (any(res$mpg != c(18.7, 21.0, 21.0, 21.4, 22.8))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("sort() function check failed.")
put(res)
} else {
put("sort() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for labels() function
dt <- datasets::mtcars
labels(dt) <- list(mpg = "Miles", cyl = "Cylin")
res <- labels(dt)
tmp <- tmplt
tmp[1, "Description"] <- "labels() function works as expected."
if (res[["mpg"]] != "Miles" || res[["cyl"]] != "Cylin") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("labels() function check failed.")
put(res)
} else {
put("label() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for roundup() function
res <- roundup(2.5)
tmp <- tmplt
tmp[1, "Description"] <- "roundup() function works as expected."
if (res != 3) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- res
put("roundup() function check failed.")
put(res)
} else {
put("roundup() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for Sys.path() function
res <- Sys.path()
tmp <- tmplt
tmp[1, "Description"] <- "Sys.path() function works as expected."
if (is.null(res) == TRUE) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Sys.path() failed to return path."
put("Sys.path() function check failed.")
put(res)
} else {
put("Sys.path() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for find.names() function
res <- find.names(datasets::mtcars, pattern = "d*")
tmp <- tmplt
tmp[1, "Description"] <- "find.names() function works as expected."
if (any(res != c("disp", "drat"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("find.names() function check failed.")
put(res)
} else {
put("find.names() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for copy.attributes() function
dt2 <- datasets::mtcars
dt2 <- copy.attributes(dt, dt2)
res <- labels(dt2)
tmp <- tmplt
tmp[1, "Description"] <- "copy.attributes() function works as expected."
if (res[["mpg"]] != "Miles" || res[["cyl"]] != "Cylin") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("copy.attributes() function check failed.")
put(res)
} else {
put("copy.attributes() function check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import logr
#' @import datasets
check_logr <- function(lpth) {
tmplt <- data.frame(Category = "logr",
Description = "Test log created.",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for test log
pth <- file.path(lpth, "test.log")
pth2 <- log_open(pth, logdir = FALSE)
log_print("Test me")
log_print(datasets::mtcars)
log_close()
tmp <- tmplt
if (file.exists(pth) == FALSE) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test log failed to create at " %p% pth
}
ret <- tmp
return(ret)
}
#' @import fmtr
#' @import datasets
check_fmtr <- function(opth) {
tmplt <- data.frame(Category = "fmtr",
Description = "fmtr test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check for fapply() function
res <- fapply(dt$wt, "%.1f")
tmp <- tmplt
tmp[1, "Description"] <- "fapply() function works as expected."
if (any(res != c("2.6", "2.9", "2.3", "3.2", "3.4"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("fapply() function check failed.")
} else {
put("fapply() function check passed.")
}
ret <- tmp
# Check for fdata() function
formats(dt) <- list(wt = "%.1f")
res <- fdata(dt)
tmp <- tmplt
tmp[1, "Description"] <- "fdata() function works as expected."
if (any(res$wt != c("2.6", "2.9", "2.3", "3.2", "3.4"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("fdata() function check failed.")
} else {
put("fdata() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for value() function
fmt <- value(condition(x > 21, "H"),
condition(x <= 21, "L"))
res <- fapply(dt$mpg, fmt)
tmp <- tmplt
tmp[1, "Description"] <- "user defined format works as expected."
if (any(res != c("L", "L", "H", "H", "L"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("value() function check failed.")
} else {
put("value() function check passed.")
}
ret <- rbind(ret, tmp)
pth <- opth
fc <- fcat(test1 = fmt,
test2 = "%5.1f")
pth2 <- write.fcat(fc, pth)
tmp <- tmplt
tmp[1, "Description"] <- "write.fcat() function works as expected."
if (!file.exists(pth2)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "test format catalog not found."
put("write.fcat() function check failed.")
} else {
put("write.fcat() function check passed.")
}
ret <- rbind(ret, tmp)
fc2 <- read.fcat(pth2)
tmp <- tmplt
tmp[1, "Description"] <- "read.fcat() function works as expected."
if (!is.fcat(fc2)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "format catalog not read properly."
put("read.fcat() function check failed.")
} else {
put("read.fcat() function check passed.")
}
ret <- rbind(ret, tmp)
res <- fapply(dt$mpg, fc2$test1)
tmp <- tmplt
tmp[1, "Description"] <- "format catalog usage works as expected."
if (any(res != c("L", "L", "H", "H", "L"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("format catalog formats check failed.")
} else {
put("format catalog formats check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import libr
#' @import datasets
check_libr <- function(dpth) {
tmplt <- data.frame(Category = "libr",
Description = "libr test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Create test data directory
dir <- system.file("extdata", package = "sassy")
file.copy(file.path(dir, "AE.csv"), file.path(dpth, "AE.csv"))
file.copy(file.path(dir, "DM.csv"), file.path(dpth, "DM.csv"))
file.copy(file.path(dir, "DS.csv"), file.path(dpth, "DS.csv"))
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check libname() function
libname(tst, dpth, "csv")
tmp <- tmplt
tmp[1, "Description"] <- "libname() created as expected."
if (!"tst" %in% ls()) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libname not created."
put("libname() function check failed.")
} else {
put("libname() function check passed.")
}
ret <- tmp
# Check libname datasets
tmp <- tmplt
tmp[1, "Description"] <- "libname() datasets found."
if (!length(tst) >= 3) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libname datasets not found. " %p% length(tst)
put("libname() dataset check failed.")
} else {
put("libname() dataset check passed.")
}
ret <- rbind(ret, tmp)
# Check lib_add()
lib_add(tst, dt)
tmp <- tmplt
tmp[1, "Description"] <- "lib_add() function works as expected."
if (!length(tst) >= 4) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "lib_add() function not working. " %p% length(tst)
put("lib_add() function check failed.")
} else {
put("lib_add() function check passed.")
}
ret <- rbind(ret, tmp)
# Check lib_remove()
lib_remove(tst, "dt")
tmp <- tmplt
tmp[1, "Description"] <- "lib_remove() function works as expected."
if ("dt" %in% names(tst)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "lib_remove() function not working."
put("lib_remove() function check failed.")
} else {
put("lib_remove() function check passed.")
}
ret <- rbind(ret, tmp)
# Check dictionary()
res <- dictionary(tst$AE)
tmp <- tmplt
tmp[1, "Description"] <- "dictionary() function works as expected."
if (!is.data.frame(res) || nrow(res) != 27) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "dictionary() function not working."
put("dictionary() function check failed.")
} else {
put("dictionary() function check passed.")
}
ret <- rbind(ret, tmp)
# Check datastep()
res <- datastep(dt,
{
if (mpg > 21)
cat <- "H"
else
cat <- "L"
})
tmp <- tmplt
tmp[1, "Description"] <- "datastep() function works as expected."
if (!"cat" %in% names(res)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "datastep() function not working."
put("datastep() function check failed.")
} else {
put("datastep() function check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import reporter
#' @import datasets
check_reporter<- function(opth) {
tmplt <- data.frame(Category = "reporter",
Description = "Test report created as expected.",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
pth <- file.path(opth, "test")
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
tbl <- create_table(dt)
tbl <- titles(tbl, "Test title")
tbl <- footnotes(tbl, "Test footnotes")
rpt <- create_report(pth, font = "Courier")
rpt <- add_content(rpt, tbl)
res <- write_report(rpt, output_type = "TXT")
# Check TXT report
tmp <- tmplt
tmp[1, "Description"] <- "Test TXT created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test TXT report does not exist."
put("Test for TXT report failed.")
} else {
put("Test for TXT report passed.")
}
ret <- tmp
# Check RTF report
res <- write_report(rpt, output_type = "RTF")
tmp <- tmplt
tmp[1, "Description"] <- "Test RTF created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test RTF report does not exist."
put("Test for RTF report failed.")
} else {
put("Test for RTF report passed.")
}
ret <- rbind(ret, tmp)
# Check PDF report
res <- write_report(rpt, output_type = "PDF")
tmp <- tmplt
tmp[1, "Description"] <- "Test PDF created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test PDF report does not exist."
put("Test for PDF report failed.")
} else {
put("Test for PDF report passed.")
}
ret <- rbind(ret, tmp)
# Check DOCX report
res <- write_report(rpt, output_type = "DOCX")
tmp <- tmplt
tmp[1, "Description"] <- "Test DOCX created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test DOCX report does not exist."
put("Test for DOCX report failed.")
} else {
put("Test for DOCX report passed.")
}
ret <- rbind(ret, tmp)
# Check HTML report
res <- write_report(rpt, output_type = "HTML")
tmp <- tmplt
tmp[1, "Description"] <- "Test HTML created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test HTML report does not exist."
put("Test for HTML report failed.")
} else {
put("Test for HTML report passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import procs
#' @import datasets
check_procs <- function(opth) {
tmplt <- data.frame(Category = "procs",
Description = "procs test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check for proc_freq() function
res <- proc_freq(dt, tables = c("cyl", "gear", comb = "cyl * gear"),
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_freq() function works as expected."
if (any(res$cyl$CNT != c(1, 3, 1)) ||
any(res$gear$CNT != c(2,3)) ||
any(res$comb$CNT != c(0, 1, 1, 2, 1, 0))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_freq() function not working."
put("proc_freq() function check failed.")
} else {
put("proc_freq() function check passed.")
}
ret <- tmp
# Check for proc_means() function
res <- proc_means(dt, var = c("cyl", "gear"),
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_means() function works as expected."
if (any(res$MEAN != c(6.0, 3.6)) ||
any(res$MIN != c(4, 3)) ||
any(res$MAX != c(8, 4))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_means() function not working."
put("proc_means() function check failed.")
} else {
put("proc_means() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for proc_ttest() function
res <- proc_ttest(dt, var = c("disp"), class = "am",
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_ttest() function works as expected."
if (any(round(res$Statistics$STDERR, 5) != c(51.00000, 17.33333,
44.11055, 53.86506)) ||
any(round(res$ConfLimits$UCLM, 9) != c(957.016441545, 217.245980649,
306.712794513, 607.490468840)) ||
any(round(res$TTests$PROBT, 8) != c(0.03264727, 0.15967144)) ||
any(round(res$Equality$FVAL, 8) != c(5.7714497))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_ttest() function not working."
put("proc_ttest() function check failed.")
} else {
put("proc_ttest() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for proc_reg() function
res <- proc_reg(dt, model = "mpg = disp",
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_reg() function works as expected."
if (any(round(res$RMSE, 8) != 0.86251743) ||
any(round(res$Intercept, 6) != 23.631007) ||
any(round(res$disp, 8) != -0.01267212)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_reg() function not working."
put("proc_reg() function check failed.")
} else {
put("proc_reg() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc transpose
res <- proc_transpose(dt)
tmp <- tmplt
tmp[1, "Description"] <- "proc_transpose() function works as expected."
if (nrow(res) != 11 ||
ncol(res) != 6) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_transpose() function not working."
put("proc_transpose() function check failed.")
} else {
put("proc_transpose() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc sort
res <- proc_sort(dt, by = "mpg")
tmp <- tmplt
tmp[1, "Description"] <- "proc_sort() function works as expected."
if (any(res$mpg != c(18.7, 21.0, 21.0, 21.4, 22.8))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_sort() function not working."
put("proc_sort() function check failed.")
} else {
put("proc_sort() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc print
res <- proc_print(dt, file.path(opth, "print.pdf"), output_type = "PDF",
titles = "Test", view = FALSE)
tmp <- tmplt
tmp[1, "Description"] <- "proc_print() function works as expected."
if (!file.exists(res)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_print() function not working."
put("proc_print() function check failed.")
} else {
put("proc_print() function check passed.")
put(res)
}
ret <- rbind(ret, tmp)
return(ret)
}
dbosak01/sassy documentation built on April 20, 2024, 8:51 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 check_procs check_reporter check_libr check_fmtr check_logr check_common check_packages run_oq
Documented in run_oq
# Needed to get command check to pass without notes
# Complaining about undeclared variables that are actually non-standard eval
utils::globalVariables(c("hello", "goodbye", "x", "tst", "mpg"))
# Operational Qualification -----------------------------------------------
#' @title Generates an Operational Qualification Report
#' @description The \code{run_oq} function executes an
#' operational qualification (OQ)
#' on the currently installed \strong{sassy} packages and generates a report
#' on the results. The OQ ensures that the \strong{sassy} packages are
#' installed and working
#' as expected. The results will be placed in the supplied location.
#' @details
#' The Operation Qualification works by executing a representative set of
#' functions from each \strong{sassy} package, and comparing the
#' results against expected values. Here is a brief description of the
#' operations performed on each package:
#' \itemize{
#' \item{\strong{logr}: A sample log is produced and checked for existence.
#' This test confirms the following functions: \code{log_open}, \code{log_print},
#' and \code{log_close}.
#' }
#' \item{\strong{fmtr}: The basic operations of the package are executed
#' and compared against expected output: \code{fapply}, \code{fdata},
#' \code{value}, \code{condition}, \code{write.fcat}, and \code{read.fcat}.
#' }
#' \item{\strong{libr}: The procedure verifies that the fundamental operations
#' of the package are working properly without errors: \code{libname},
#' \code{lib_add}, \code{lib_remove}, \code{dictionary}, and \code{datastep}.
#' }
#' \item{\strong{reporter}: The reporter package is tested by producing
#' sample reports in each of the available output types: TXT, HTML,
#' RTF, PDF, and DOCX. This method tests almost all of the sub-functions
#' of the package.
#' }
#' \item{\strong{common}: The following representative functions are
#' run and tested for errors and valid return values: \code{v},
#' \code{sort}, \code{labels},
#' \code{roundup}, \code{Sys.path}, \code{find.names},
#' and \code{copy.attributes}.
#' }
#' \item{\strong{procs}: All the major functions of the package are
#' executed and tested against expected results: \code{proc_freq},
#' \code{proc_means}, \code{proc_transpose}, \code{proc_sort}, and
#' \code{proc_print}.
#' }
#' }
#'
#' @param location The path to the desired output directory. The IQ
#' reports and any other associated files will be placed in this directory.
#' Location should be specified as a directory only. The file names
#' will be generated by the function.
#' @return The path to the output directory. This directory will
#' contain subdirectories with the output reports, logs, and other files
#' produced by the Operation Qualification. At the top level, the directory
#' will contain a PDF report showing a summary of the results of the OQ. After
#' the function is run, review this report to ensure that all tests passed.
#' @examples
#' # Create a temp directory
#' tmp <- tempdir()
#'
#' # Uncomment to Run the Operational Qualification
#' # run_oq(tmp)
#' @export
run_oq <- function(location) {
if (!dir.exists(location)) {
dir.create(opth, recursive = TRUE)
}
# Create needed folders
dpth <- file.path(location, "data")
if (!dir.exists(dpth))
dir.create(dpth)
opth <- file.path(location, "output")
if (!dir.exists(opth))
dir.create(opth)
lpth <- file.path(location, "log")
if (!dir.exists(lpth))
dir.create(lpth)
# Initialize output data frame
ret <- data.frame(Category = "sassy",
Description = "System Initialization",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check that all sassy packages exist
ret <- rbind(ret, check_packages())
# Checks for logr package
ret <- rbind(ret, check_logr(opth))
# Now that log is tested and packages exist, create run log
lg <- log_open(file.path(lpth, "runOQ.log"), logdir = FALSE,
show_notes = FALSE, autolog = TRUE)
sep("Initialization results")
put(ret)
if (all(ret$Pass == TRUE)) {
sep("Package Checks")
sep("Checks for common package")
ret <- rbind(ret, check_common())
sep("Checks for fmtr package")
ret <- rbind(ret, check_fmtr(opth))
sep("Checks for libr package")
ret <- rbind(ret, check_libr(dpth))
sep("Checks for reporter package")
ret <- rbind(ret, check_reporter(opth))
sep("Checks for procs package")
ret <- rbind(ret, check_procs(opth))
} else {
put("OQ run stopped due to initalization failure.")
}
sep("Preparing Report")
put("Complete Results: ")
put(ret)
# Print report
ttls <- c("Operational Qualification Results Report",
"SASSY System")
pth <- file.path(location, "sassyOQ-" %p% Sys.Date())
put("Printing report")
put("Report path: " %p% pth)
res <- print_report(pth, ret, ttls)
view_report(ret, ttls)
log_close()
return(res)
}
# OQ Subroutines ----------------------------------------------------------
check_packages <- function() {
tmplt <- data.frame(Category = "sassy",
Description = "System Initialization",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for logr package
res <- system.file(package = "logr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for logr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "logr package not found."
}
ret <- tmp
# Check for fmtr package
res <- system.file(package = "fmtr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for fmtr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "fmtr package not found."
}
ret <- rbind(ret, tmp)
# Check for common package
res <- system.file(package = "common")
tmp <- tmplt
tmp[1, "Description"] <- "Check for common package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "common package not found."
}
ret <- rbind(ret, tmp)
# Check for libr package
res <- system.file(package = "libr")
tmp <- tmplt
tmp[1, "Description"] <- "Check for libr package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libr package not found."
}
ret <- rbind(ret, tmp)
# Check for reporter package
res <- system.file(package = "reporter")
tmp <- tmplt
tmp[1, "Description"] <- "Check for reporter package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "reporter package not found."
}
ret <- rbind(ret, tmp)
# Check for procs package
res <- system.file(package = "procs")
tmp <- tmplt
tmp[1, "Description"] <- "Check for procs package installation."
if (res == "") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "procs package not found."
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import common
#' @import datasets
check_common <- function() {
tmplt <- data.frame(Category = "common",
Description = "Common test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for v() function
res <- v(hello, goodbye)
tmp <- tmplt
tmp[1, "Description"] <- "v() function works as expected."
if (any(res != c("hello", "goodbye"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("v() function check failed.")
put(res)
} else {
put("v() function check passed.")
}
ret <- tmp
# Check for sort() function
res <- sort(datasets::mtcars[1:5, ], by = 'mpg')
tmp <- tmplt
tmp[1, "Description"] <- "sort() function works as expected."
if (any(res$mpg != c(18.7, 21.0, 21.0, 21.4, 22.8))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("sort() function check failed.")
put(res)
} else {
put("sort() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for labels() function
dt <- datasets::mtcars
labels(dt) <- list(mpg = "Miles", cyl = "Cylin")
res <- labels(dt)
tmp <- tmplt
tmp[1, "Description"] <- "labels() function works as expected."
if (res[["mpg"]] != "Miles" || res[["cyl"]] != "Cylin") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("labels() function check failed.")
put(res)
} else {
put("label() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for roundup() function
res <- roundup(2.5)
tmp <- tmplt
tmp[1, "Description"] <- "roundup() function works as expected."
if (res != 3) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- res
put("roundup() function check failed.")
put(res)
} else {
put("roundup() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for Sys.path() function
res <- Sys.path()
tmp <- tmplt
tmp[1, "Description"] <- "Sys.path() function works as expected."
if (is.null(res) == TRUE) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Sys.path() failed to return path."
put("Sys.path() function check failed.")
put(res)
} else {
put("Sys.path() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for find.names() function
res <- find.names(datasets::mtcars, pattern = "d*")
tmp <- tmplt
tmp[1, "Description"] <- "find.names() function works as expected."
if (any(res != c("disp", "drat"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("find.names() function check failed.")
put(res)
} else {
put("find.names() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for copy.attributes() function
dt2 <- datasets::mtcars
dt2 <- copy.attributes(dt, dt2)
res <- labels(dt2)
tmp <- tmplt
tmp[1, "Description"] <- "copy.attributes() function works as expected."
if (res[["mpg"]] != "Miles" || res[["cyl"]] != "Cylin") {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("copy.attributes() function check failed.")
put(res)
} else {
put("copy.attributes() function check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import logr
#' @import datasets
check_logr <- function(lpth) {
tmplt <- data.frame(Category = "logr",
Description = "Test log created.",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Check for test log
pth <- file.path(lpth, "test.log")
pth2 <- log_open(pth, logdir = FALSE)
log_print("Test me")
log_print(datasets::mtcars)
log_close()
tmp <- tmplt
if (file.exists(pth) == FALSE) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test log failed to create at " %p% pth
}
ret <- tmp
return(ret)
}
#' @import fmtr
#' @import datasets
check_fmtr <- function(opth) {
tmplt <- data.frame(Category = "fmtr",
Description = "fmtr test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check for fapply() function
res <- fapply(dt$wt, "%.1f")
tmp <- tmplt
tmp[1, "Description"] <- "fapply() function works as expected."
if (any(res != c("2.6", "2.9", "2.3", "3.2", "3.4"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("fapply() function check failed.")
} else {
put("fapply() function check passed.")
}
ret <- tmp
# Check for fdata() function
formats(dt) <- list(wt = "%.1f")
res <- fdata(dt)
tmp <- tmplt
tmp[1, "Description"] <- "fdata() function works as expected."
if (any(res$wt != c("2.6", "2.9", "2.3", "3.2", "3.4"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("fdata() function check failed.")
} else {
put("fdata() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for value() function
fmt <- value(condition(x > 21, "H"),
condition(x <= 21, "L"))
res <- fapply(dt$mpg, fmt)
tmp <- tmplt
tmp[1, "Description"] <- "user defined format works as expected."
if (any(res != c("L", "L", "H", "H", "L"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("value() function check failed.")
} else {
put("value() function check passed.")
}
ret <- rbind(ret, tmp)
pth <- opth
fc <- fcat(test1 = fmt,
test2 = "%5.1f")
pth2 <- write.fcat(fc, pth)
tmp <- tmplt
tmp[1, "Description"] <- "write.fcat() function works as expected."
if (!file.exists(pth2)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "test format catalog not found."
put("write.fcat() function check failed.")
} else {
put("write.fcat() function check passed.")
}
ret <- rbind(ret, tmp)
fc2 <- read.fcat(pth2)
tmp <- tmplt
tmp[1, "Description"] <- "read.fcat() function works as expected."
if (!is.fcat(fc2)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "format catalog not read properly."
put("read.fcat() function check failed.")
} else {
put("read.fcat() function check passed.")
}
ret <- rbind(ret, tmp)
res <- fapply(dt$mpg, fc2$test1)
tmp <- tmplt
tmp[1, "Description"] <- "format catalog usage works as expected."
if (any(res != c("L", "L", "H", "H", "L"))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- paste(res, collapse = " ", sep = " ")
put("format catalog formats check failed.")
} else {
put("format catalog formats check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import libr
#' @import datasets
check_libr <- function(dpth) {
tmplt <- data.frame(Category = "libr",
Description = "libr test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
# Create test data directory
dir <- system.file("extdata", package = "sassy")
file.copy(file.path(dir, "AE.csv"), file.path(dpth, "AE.csv"))
file.copy(file.path(dir, "DM.csv"), file.path(dpth, "DM.csv"))
file.copy(file.path(dir, "DS.csv"), file.path(dpth, "DS.csv"))
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check libname() function
libname(tst, dpth, "csv")
tmp <- tmplt
tmp[1, "Description"] <- "libname() created as expected."
if (!"tst" %in% ls()) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libname not created."
put("libname() function check failed.")
} else {
put("libname() function check passed.")
}
ret <- tmp
# Check libname datasets
tmp <- tmplt
tmp[1, "Description"] <- "libname() datasets found."
if (!length(tst) >= 3) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "libname datasets not found. " %p% length(tst)
put("libname() dataset check failed.")
} else {
put("libname() dataset check passed.")
}
ret <- rbind(ret, tmp)
# Check lib_add()
lib_add(tst, dt)
tmp <- tmplt
tmp[1, "Description"] <- "lib_add() function works as expected."
if (!length(tst) >= 4) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "lib_add() function not working. " %p% length(tst)
put("lib_add() function check failed.")
} else {
put("lib_add() function check passed.")
}
ret <- rbind(ret, tmp)
# Check lib_remove()
lib_remove(tst, "dt")
tmp <- tmplt
tmp[1, "Description"] <- "lib_remove() function works as expected."
if ("dt" %in% names(tst)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "lib_remove() function not working."
put("lib_remove() function check failed.")
} else {
put("lib_remove() function check passed.")
}
ret <- rbind(ret, tmp)
# Check dictionary()
res <- dictionary(tst$AE)
tmp <- tmplt
tmp[1, "Description"] <- "dictionary() function works as expected."
if (!is.data.frame(res) || nrow(res) != 27) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "dictionary() function not working."
put("dictionary() function check failed.")
} else {
put("dictionary() function check passed.")
}
ret <- rbind(ret, tmp)
# Check datastep()
res <- datastep(dt,
{
if (mpg > 21)
cat <- "H"
else
cat <- "L"
})
tmp <- tmplt
tmp[1, "Description"] <- "datastep() function works as expected."
if (!"cat" %in% names(res)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "datastep() function not working."
put("datastep() function check failed.")
} else {
put("datastep() function check passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import reporter
#' @import datasets
check_reporter<- function(opth) {
tmplt <- data.frame(Category = "reporter",
Description = "Test report created as expected.",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
pth <- file.path(opth, "test")
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
tbl <- create_table(dt)
tbl <- titles(tbl, "Test title")
tbl <- footnotes(tbl, "Test footnotes")
rpt <- create_report(pth, font = "Courier")
rpt <- add_content(rpt, tbl)
res <- write_report(rpt, output_type = "TXT")
# Check TXT report
tmp <- tmplt
tmp[1, "Description"] <- "Test TXT created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test TXT report does not exist."
put("Test for TXT report failed.")
} else {
put("Test for TXT report passed.")
}
ret <- tmp
# Check RTF report
res <- write_report(rpt, output_type = "RTF")
tmp <- tmplt
tmp[1, "Description"] <- "Test RTF created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test RTF report does not exist."
put("Test for RTF report failed.")
} else {
put("Test for RTF report passed.")
}
ret <- rbind(ret, tmp)
# Check PDF report
res <- write_report(rpt, output_type = "PDF")
tmp <- tmplt
tmp[1, "Description"] <- "Test PDF created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test PDF report does not exist."
put("Test for PDF report failed.")
} else {
put("Test for PDF report passed.")
}
ret <- rbind(ret, tmp)
# Check DOCX report
res <- write_report(rpt, output_type = "DOCX")
tmp <- tmplt
tmp[1, "Description"] <- "Test DOCX created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test DOCX report does not exist."
put("Test for DOCX report failed.")
} else {
put("Test for DOCX report passed.")
}
ret <- rbind(ret, tmp)
# Check HTML report
res <- write_report(rpt, output_type = "HTML")
tmp <- tmplt
tmp[1, "Description"] <- "Test HTML created as expected."
if (!file.exists(res$modified_path)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "Test HTML report does not exist."
put("Test for HTML report failed.")
} else {
put("Test for HTML report passed.")
}
ret <- rbind(ret, tmp)
return(ret)
}
#' @import procs
#' @import datasets
check_procs <- function(opth) {
tmplt <- data.frame(Category = "procs",
Description = "procs test",
Pass = TRUE,
Message = "",
stringsAsFactors = FALSE)
dt <- datasets::mtcars[1:5, ]
put("Source dataset:")
put(dt)
# Check for proc_freq() function
res <- proc_freq(dt, tables = c("cyl", "gear", comb = "cyl * gear"),
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_freq() function works as expected."
if (any(res$cyl$CNT != c(1, 3, 1)) ||
any(res$gear$CNT != c(2,3)) ||
any(res$comb$CNT != c(0, 1, 1, 2, 1, 0))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_freq() function not working."
put("proc_freq() function check failed.")
} else {
put("proc_freq() function check passed.")
}
ret <- tmp
# Check for proc_means() function
res <- proc_means(dt, var = c("cyl", "gear"),
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_means() function works as expected."
if (any(res$MEAN != c(6.0, 3.6)) ||
any(res$MIN != c(4, 3)) ||
any(res$MAX != c(8, 4))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_means() function not working."
put("proc_means() function check failed.")
} else {
put("proc_means() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for proc_ttest() function
res <- proc_ttest(dt, var = c("disp"), class = "am",
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_ttest() function works as expected."
if (any(round(res$Statistics$STDERR, 5) != c(51.00000, 17.33333,
44.11055, 53.86506)) ||
any(round(res$ConfLimits$UCLM, 9) != c(957.016441545, 217.245980649,
306.712794513, 607.490468840)) ||
any(round(res$TTests$PROBT, 8) != c(0.03264727, 0.15967144)) ||
any(round(res$Equality$FVAL, 8) != c(5.7714497))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_ttest() function not working."
put("proc_ttest() function check failed.")
} else {
put("proc_ttest() function check passed.")
}
ret <- rbind(ret, tmp)
# Check for proc_reg() function
res <- proc_reg(dt, model = "mpg = disp",
options = "noprint")
tmp <- tmplt
tmp[1, "Description"] <- "proc_reg() function works as expected."
if (any(round(res$RMSE, 8) != 0.86251743) ||
any(round(res$Intercept, 6) != 23.631007) ||
any(round(res$disp, 8) != -0.01267212)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_reg() function not working."
put("proc_reg() function check failed.")
} else {
put("proc_reg() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc transpose
res <- proc_transpose(dt)
tmp <- tmplt
tmp[1, "Description"] <- "proc_transpose() function works as expected."
if (nrow(res) != 11 ||
ncol(res) != 6) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_transpose() function not working."
put("proc_transpose() function check failed.")
} else {
put("proc_transpose() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc sort
res <- proc_sort(dt, by = "mpg")
tmp <- tmplt
tmp[1, "Description"] <- "proc_sort() function works as expected."
if (any(res$mpg != c(18.7, 21.0, 21.0, 21.4, 22.8))) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_sort() function not working."
put("proc_sort() function check failed.")
} else {
put("proc_sort() function check passed.")
}
ret <- rbind(ret, tmp)
# Check proc print
res <- proc_print(dt, file.path(opth, "print.pdf"), output_type = "PDF",
titles = "Test", view = FALSE)
tmp <- tmplt
tmp[1, "Description"] <- "proc_print() function works as expected."
if (!file.exists(res)) {
tmp[1, "Pass"] <- FALSE
tmp[1, "Message"] <- "proc_print() function not working."
put("proc_print() function check failed.")
} else {
put("proc_print() function check passed.")
put(res)
}
ret <- rbind(ret, tmp)
return(ret)
}
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.