# Copyright (C) Brodie Gaslam
#
# This file is part of "unitizer - Interactive R Unit Tests"
#
# This program 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.
#
# This program 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.
#
# Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
#' Demo Details and Helper Functions
#'
#' \code{unitizer} provides an interactive demo you can run with
#' \code{demo("unitizer")}.
#'
#' @section Demo Details:
#'
#' The demo centers around simulated development of the \code{utzflm}
#' package. \code{unitizer} includes in its sources three copies of the source
#' code for the \code{utzflm} package, each at a different stage of
#' development. This allows us to create reference \code{unitizer} tests under
#' one version, move to a new version and check for regressions, and finally
#' fix the regressions with the last version. The version switching is
#' intended to represent the package development process.
#'
#' The demo manages the \code{utzflm} code changes, but between each
#' update allows the user to interact with \code{unitizer}. The demo operates
#' under the assumption that the user will accept the first set of tests and
#' reject the failing tests after the first update. If the user does anything
#' different then the demo commentary may not apply anymore.
#'
#' @section \code{utzflm}:
#'
#' \code{utzflm} is a "dummy" package that implements a faster
#' computation of slope, intercept, and R^2 for single variable linear
#' regressions than is available via \code{summary(lm()...)}.
#'
#' @section Helper Functions:
#'
#' \code{copy_fastlm_to_tmpdir} copies the initial version of the
#' \code{utzflm} sources to a temporary directory, \code{show_file}
#' displays the contents of a source code file, \code{update_fastlm} changes the
#' source code of \code{utzflm}, and \code{unitizer_check_demo_state}
#' and \code{unitizer_cleanup_demo} perform janitorial functions. None of
#' these functions are intended for use outside of the unitizer demo.
#'
#' @rdname demo
#' @name unitizer_demo
#' @param f path to a file
#' @param dir path to the temporary package
#' @param width display width in characters
#' @param version one of "0.1.0", "0.1.1", "0.1.2"
#' @return character(1L)
NULL
# nocov start
#' @export
#' @rdname demo
`[Press ENTER to Continue]` <- function() invisible(readline())
# nocov end
#' @export
#' @rdname demo
show_file <- function(f, width=getOption("width", 80L)) {
stopifnot(is.chr1(f))
txt <- try(readLines(f))
pkg.dir <- get_package_dir(f)
if(length(pkg.dir)) f <- relativize_path(f, pkg.dir)
if(inherits(txt, "try-error")) stop("Unable to open file")
line.num <- seq_along(txt)
line.chars <- max(nchar(line.num))
txt.wrap <- lapply(txt, word_wrap, width=width - 7L)
txt.wrap.lines <- vapply(txt.wrap, length, integer(1L))
line.txt <-format(
unlist(
Map(function(x, y) c(x, rep("", y - 1L)), line.num, txt.wrap.lines)
),
justify="right"
)
line.txt.chars <- nchar(line.txt[[1L]]) + 2L
body <- paste0("| ", line.txt, " | ", format(unlist(txt.wrap)), " |")
body.chrs <- nchar(body[[1L]])
file.disp <- word_wrap(f, width=nchar(body[[1L]]) - 4L, hyphens=FALSE)
bar <- paste0(
c(
"+", rep("-", line.txt.chars), "+",
rep("-", body.chrs - line.txt.chars - 3L), "+"
),
collapse=""
)
top.bar <- paste0(c("+", rep("-", body.chrs - 2L), "+"), collapse="")
file.disp[[1L]] <- paste0(
c(
file.disp[[1L]],
rep(" ", max(body.chrs - nchar(file.disp[[1L]]) - 4L, 0L))
),
collapse=""
)
res <- c(top.bar, paste0("| ", format(file.disp), " |"), bar, body, bar)
cat(res, sep="\n")
invisible(res)
}
#' @export
#' @rdname demo
copy_fastlm_to_tmpdir <- function() {
dir <- file.path(tempfile(), "utzflm")
if(inherits(try(dir.create(dir, recursive=TRUE)), "try-error"))
stop("Unable to create temporary directory '", dir, "'")
untz.dir <- system.file(package="unitizer")
fastlm.dir <- file.path(untz.dir, "expkg", "flm0")
fastlm.files <- list.files(
fastlm.dir, full.names=TRUE, include.dirs=TRUE, no..=TRUE
)
if(inherits(try(file.copy(fastlm.files, dir, recursive=TRUE)), "try-error"))
stop("Unable to copy `fastlm` sources")
# need to do this because R CMD build removes files ending in .Rcheck, and
# complains about "pre-installed" package in sources, when we explcitly need a
# pre installed structure for a different dummy package for our tests
fastlm.check <- file.path(dir, "utzflm_Rcheck")
fastlm.check.new <- file.path(dir, "utzflm.Rcheck")
if(inherits(try(file.rename(fastlm.check, fastlm.check.new)), "try-error"))
stop("Unable to rename fastlm check directory")
check.dirs <- list.files(
file.path(fastlm.check.new, "utzflm"), full.names=TRUE
)
if(
inherits(
try(
file.rename(
check.dirs,
file.path(dirname(check.dirs), sub("^_", "", basename(check.dirs)))
) ),
"try-error"
) )
stop("Unable to unmask package sub dirs")
dir
}
# Helper fun for update_fastlm_*
.test.core.files <- c(
"DESCRIPTION", file.path("R", "fastlm.R"),
file.path(
"tests", "unitizer", c("fastlm1.R", "fastlm2.R", "unitizer.fastlm.R")
) )
check_test_dir <- function(dir) {
stopifnot(
file_test("-d", dir),
file_test("-d", file.path(dir, "tests", "unitizer")),
all(file_test("-f", file.path(dir, .test.core.files)))
)
}
#' @export
#' @rdname demo
update_fastlm <- function(dir, version) {
check_test_dir(dir)
try(detach("package:utzflm", unload=TRUE), silent=TRUE)
stopifnot(version %in% c("0.1.0", "0.1.1", "0.1.2"))
lm.dir <- switch(
version, "0.1.0"="flm0", "0.1.1"="flm1", "0.1.2"="flm2",
stop("Internal Error; unknown version") # nocov
)
untz.dir <- system.file(package="unitizer")
lm.dir.full <- file.path(untz.dir, "expkg", lm.dir)
cpy.files <- .test.core.files
cpy.from <- file.path(lm.dir.full, cpy.files)
cpy.to <- file.path(dir, cpy.files)
invisible(file.copy(cpy.from, cpy.to, overwrite=TRUE))
}
# copy extra file for tests, this is primarily just for the section tests and
# should be used with care as it will mess up all the other tests by adding
# an extra file. This also installs version 0.1.2
update_fastlm_extra <- function(dir) {
try(detach("package:utzflm", unload=TRUE), silent=TRUE)
check_test_dir(dir)
lm.dir <- "flm2"
untz.dir <- system.file(package="unitizer")
lm.dir.full <- file.path(untz.dir, "expkg", lm.dir)
file.extra <- file.path("tests", "unitizer", "unitizer.fastlm2.R")
stopifnot(
file_test("-f", file.path(lm.dir.full, file.extra))
)
cpy.files <- c(.test.core.files, file.extra)
cpy.from <- file.path(lm.dir.full, cpy.files)
cpy.to <- file.path(dir, cpy.files)
invisible(file.copy(cpy.from, cpy.to, overwrite=TRUE))
}
# nocov start
#' @export
#' @rdname demo
unitizer_check_demo_state <- function() {
vars <- c(".unitizer.fastlm", ".unitizer.test.file")
vars.exist <- logical(length(vars))
for(i in seq_along(vars))
vars.exist[[i]] <- exists(vars[[i]], envir=parent.frame(), inherits=FALSE)
if(any(vars.exist)) {
meta_word_msg(
"Variables", paste0("`", vars, "`", collapse=", "), " already exist, but",
"must be overwritten for demo to proceed. These could have been left",
"over by a previous run of the demo that did not complete properly.",
sep=" "
)
choice <- simple_prompt("Overwrite variables?")
if(!identical(choice, "Y")) stop("Cannot continue demo.")
rm(list=vars[vars.exist], envir=parent.frame())
}
if("utzflm" %in% rownames(installed.packages())) {
meta_word_msg(
"'utzflm' pacakge already installed. This could be because of ",
"a prior demo run that was unable to clean-up properly after itself. ",
"Continuing with demo will overwrite existing installation.",
sep=" "
)
choice <- simple_prompt("Overwrite existing installation?")
if(!identical(choice, "Y")) stop("Cannot continue demo.")
}
}
# nocov end
#' @export
#' @rdname demo
unitizer_cleanup_demo <- function() {
vars <- c(".unitizer.fastlm", ".unitizer.test.file")
try(detach("package:utzflm"), silent=TRUE)
try(unloadNamespace("utzflm"), silent=TRUE)
try(remove.packages("utzflm", .libPaths()[[1L]]), silent=TRUE)
pkg.dir <- try(get(".unitizer.fastlm", envir=parent.frame()))
if(
!inherits(pkg.dir, "try-error") && is.chr1plain(pkg.dir) &&
file_test("-d", pkg.dir) && grepl("unitizer\\.fastlm$", pkg.dir)
)
unlink(pkg.dir, recursive=TRUE)
unlink(getOption('unitizer.tmp.lib.loc'), recursive=TRUE)
options(unitizer.tmp.lib.loc=NULL)
rm(list=vars, envir=parent.frame())
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.