R/doGauge.R

In propagate: Propagation of Uncertainty

doGauge <- function(demo = c("JCGM100", "JCGM101", "JCGM102", "JCGM106", "EMUE", "NIST1900", "QUAM", "COPULA"), output = c("html", "pdf"),
                  outdir = tempdir(), fontsize = 20, silent = TRUE,
                  dir = system.file("demo", package = "propagate"))
{
  demo <- match.arg(demo, several.ok = TRUE); output <- match.arg(output)
   op <- options(width = 200, crayon.enabled = FALSE)
  on.exit(options(op))
  FILES <- character(0); SUM <- NULL
  for (d in demo) {
    cat("Running demo", d, "...\n")
    path <- file.path(dir, paste0(d, ".R"))
    run <- function() utils::capture.output(source(path, echo = TRUE, print.eval = TRUE, max.deparse.length = Inf,
                                                   local = new.env(), spaced = FALSE))
    grDevices::pdf(NULL)                                              ## plots of the demos are discarded
    TXT <- if (silent) suppressWarnings(suppressMessages(run())) else run()
    grDevices::dev.off()
    plain <- gsub("\033\\[[0-9;]*m", "", TXT)                         ## without colour codes
    res <- regmatches(plain, regexpr("(PASS|NOTE|DIFF)$", plain)); res <- res[res %in% c("PASS", "NOTE", "DIFF")]
    SUM <- rbind(SUM, data.frame(demo = d, PASS = sum(res == "PASS"), NOTE = sum(res == "NOTE"), DIFF = sum(res == "DIFF")))
    isCode <- grepl("^[>+] ", plain)
    head1 <- paste0("propagate ", utils::packageVersion("propagate"), ": demo ", d)
    head2 <- paste0(format(Sys.time()), " - ", R.version.string)
    
    if (output == "html") {
      esc <- function(x) gsub(">", "&gt;", gsub("<", "&lt;", gsub("&", "&amp;", x, fixed = TRUE), fixed = TRUE), fixed = TRUE)
      H <- esc(plain)
      H[isCode] <- paste0("<span class='code'>", H[isCode], "</span>")
      H[!isCode] <- gsub("  PASS$", "  <b style='color:#00AA00'>PASS</b>", H[!isCode])
      H[!isCode] <- gsub("  NOTE$", "  <b style='color:#AA0000'>NOTE</b>", H[!isCode])
      H[!isCode] <- gsub("  DIFF$", "  <b style='color:#0000AA'>DIFF</b>", H[!isCode])
      H[!isCode] <- gsub("(published|propagate)(?= )", "<b>\\1</b>", H[!isCode], perl = TRUE)
      out <- file.path(outdir, paste0(d, ".html"))
      writeLines(c("<!DOCTYPE html><html><head><meta charset='utf-8'>", paste0("<title>", head1, "</title><style>"),
                   "body { font-family: sans-serif; margin: 1.5em; }",
                   paste0("pre { font-size: ", fontsize, "px; line-height: 1.3; white-space: pre; overflow-x: auto; }"),
                   ".code { color: #666666; }", "</style></head><body>",
                   paste0("<h2>", head1, "</h2><p>", head2, "</p><pre>"), H, "</pre></body></html>"), out)
    }
    
    if (output == "pdf") {
      out <- file.path(outdir, paste0(d, ".pdf"))
      grDevices::pdf(out, width = 11.69, height = 8.27, family = "Courier")      ## A4 landscape, monospaced
      op2 <- graphics::par(mar = c(0, 0, 0, 0)); graphics::plot.new()
      cex <- min(fontsize/14 * 0.75, 0.94/graphics::strwidth(plain[which.max(nchar(plain))], cex = 1))
      lh <- 2 * graphics::strheight("M", cex = cex); nPage <- floor(0.88/lh)
      ## one line, drawn segment by segment: bold words and the coloured result
      drawLine <- function(s, y, code) {
        if (code) { graphics::text(0.03, y, s, adj = c(0, 0.5), cex = cex, col = "#666666"); return(invisible()) }
        seg <- regmatches(s, gregexpr("published(?= )|propagate(?= )|(PASS|NOTE|DIFF)$|.+?(?=published |propagate |(PASS|NOTE|DIFF)$)|.+$",
                                      s, perl = TRUE))[[1]]
        x <- 0.03
        for (g in seg) {
          col <- switch(g, PASS = "#00AA00", NOTE = "#AA0000", DIFF = "#0000AA", "black")
          font <- if (g %in% c("published", "propagate", "PASS", "NOTE", "DIFF")) 2 else 1
          graphics::text(x, y, g, adj = c(0, 0.5), cex = cex, col = col, font = font)
          x <- x + graphics::strwidth(g, cex = cex, font = font)
        }
      }
      pages <- split(seq_along(plain), ceiling(seq_along(plain)/nPage))
      for (p in seq_along(pages)) {
        if (p > 1) graphics::plot.new()
        graphics::text(0.03, 0.97, head1, adj = c(0, 0.5), font = 2, cex = 0.9)
        graphics::text(0.97, 0.97, paste0(head2, "  -  page ", p, "/", length(pages)), adj = c(1, 0.5), cex = 0.6, col = "grey40")
        y <- 0.93
        for (i in pages[[p]]) { drawLine(plain[i], y, isCode[i]); y <- y - lh }
      }
      graphics::par(op2); grDevices::dev.off()
    }
    FILES <- c(FILES, out)
  }
  cat("\n")
  print(SUM, row.names = FALSE)
  invisible(list(files = FILES, summary = SUM))
}