Merge pull request #89 from carpentries/post-build-summary

add summary elements

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: pegboard
 Title: Explore and Manipulate Markdown Curricula from the Carpentries
-Version: 0.2.7
+Version: 0.3.0
 Authors@R: c(
     person(given = "Zhian N.",
            family = "Kamvar",

NEWS.md

@@ -1,4 +1,36 @@
-# pegboard 0.2.7
+# pegboard 0.3.0
+
+## NEW FEATURES
+
+### Episode class objects
+
+ - `$summary()` method which can summarise counts of elements in the episode.
+ - fixes for `$error` and `$output` active bindings
+ - new `$warning` active binding that will show code blocks with the `warning`
+   class.
+
+### Lesson class objects
+
+ - new public field "built" that will contain XML representations of 
+   markdown files built from RMarkdown files in sandpaper lessons.
+ - new public field "sandpaper" is a boolean that indicates if a lesson can be
+   built with sandpaper.
+ - new `$load_built()` method will load the built files if they exist in a
+   sandpaper lesson.
+ - new `$get()` method which will get any element from any Episode class object
+   contained within.
+ - new `$summary()` method which will call the `$summary()` method for any
+   Episode class object.
+
+### Messages
+
+ - `muffle_messages()` is an internal function that will muffle any messages
+   that originate from the {cli} or {pegboard} packages.
+ - If the {cli} package is not available, messages will have the class of
+   `pbMessage`, which will allow end users/package authors to catch and
+   manipulate any messages that originate from {pegboard}
+
+# pegboard 0.2.7 (unreleased, no user-visible changes)
 
 ## TRANSFORMATION
 

R/Episode.R

@@ -106,7 +106,7 @@ Episode <- R6::R6Class("Episode",
               {e$message}
               Section (div) tags for {self$name} will not be labelled"
             )
-            message(msg, call. = FALSE)
+            pb_message(msg, call. = FALSE)
             self
           })
       )
@@ -367,7 +367,7 @@ Episode <- R6::R6Class("Episode",
     write = function(path = NULL, format = "md", edit = FALSE) {
       if (is.null(path)) {
         path <- fs::file_temp(pattern = "dir")
-        message(glue::glue("Creating temporary directory '{path}'"))
+        pb_message(glue::glue("Creating temporary directory '{path}'"))
         fs::dir_create(path)
       }
       if (!fs::dir_exists(path)) {
@@ -478,6 +478,42 @@ Episode <- R6::R6Class("Episode",
       private$mutations['unblock'] <- TRUE
       invisible(self)
     },
+
+    #' @description Get a high-level summary of the elements in the episode
+    #' @return a data frame with counts of the following elements per page:
+    #'  - sections: level 2 headings
+    #'  - headings: all headings
+    #'  - callouts: all callouts
+    #'  - challenges: subset of callouts
+    #'  - solutions: subset of callouts
+    #'  - code: all code block elements (excluding inline code)
+    #'  - output: subset of code that is displayed as output
+    #'  - warnining: subset of code that is displayed as a warning
+    #'  - error: subset of code that is displayed as an error
+    #'  - images: all images in markdown or HTML
+    #'  - links: all links in markdown or HTML
+    summary = function() {
+      sandpaper <- any(private$mutations[c('use_sandpaper_md', 'use_sandpaper_rmd')])
+      if (!sandpaper) {
+       issue_warning("Summary not guaranteed for kramdown formatted files.")
+      }
+      res <- list(
+        sections = list(),
+        headings = self$headings, 
+        callouts = if (sandpaper) self$get_divs() else self$get_blocks(),
+        challenges = self$challenges,
+        solutions = self$solutions,
+        code = self$code,
+        output = self$output,
+        warning = self$warning,
+        error = self$error,
+        images = self$get_images(process = TRUE),
+        links = self$links
+      )
+      res$sections <- res$headings[xml2::xml_attr(res$headings, "level") == 2]
+      purrr::map_int(res, length)
+    },
+
     #' @description perform validation on headings in a document.
     #'
     #' This will validate the following aspects of all headings:
@@ -638,19 +674,27 @@ Episode <- R6::R6Class("Episode",
     #' @field output \[`xml_nodeset`\] all the output blocks from the episode
     output = function() {
       if (any(private$mutations[c('use_sandpaper_md', 'use_sandpaper_rmd')])) {
-        self$code[which(xml2::xml_attr(self$code, "info") == "output")]
+        find_code_type(self$code, "output")
       } else {
         get_code(self$body, ".output")
       }
     },
     #' @field error \[`xml_nodeset`\] all the error blocks from the episode
     error = function() {
       if (any(private$mutations[c('use_sandpaper_md', 'use_sandpaper_rmd')])) {
-        self$code[which(xml2::xml_attr(self$code, "info") == "error")]
+        find_code_type(self$code, "error")
       } else {
         get_code(self$body, ".error")
       }
     },
+    #' @field warning \[`xml_nodeset`\] all the warning blocks from the episode
+    warning = function() {
+      if (any(private$mutations[c('use_sandpaper_md', 'use_sandpaper_rmd')])) {
+        find_code_type(self$code, "warning")
+      } else {
+        get_code(self$body, ".warning")
+      }
+    },
     #' @field code \[`xml_nodeset`\] all the code blocks from the episode
     code = function() {
       get_code(self$body, type = NULL, attr = NULL)

R/Lesson.R

@@ -17,14 +17,23 @@ Lesson <- R6::R6Class("Lesson",
     #'   the episodes of the lesson.
     episodes = NULL,
 
+    #' @field built \[`list`\] list of [Episode] class objects representing
+    #'   the markdown artefacts rendered from RMarkdown files.
+    built = NULL,
+
     #' @field extra \[`list`\] list of [Episode] class objects representing
     #'   the extra markdown components including index, setup, information
     #'   for learners, information for instructors, and learner profiles. This
     #'   is not processed for the jekyll lessons.
     extra = NULL,
 
+    #' @field sandpaper \[`logical`\] when `TRUE`, the episodes in the lesson
+    #'   are written in pandoc flavoured markdown. `FALSE` would indicate a 
+    #'   jekyll-based lesson written in kramdown.
+    sandpaper = TRUE,
+
     #' @field rmd \[`logical`\] when `TRUE`, the episodes represent RMarkdown
-    #'   files, default is `FALSE` for markdown files.
+    #'   files, default is `FALSE` for markdown files (deprecated and unused).
     rmd = FALSE,
 
     #' @description create a new Lesson object from a directory
@@ -51,6 +60,7 @@ Lesson <- R6::R6Class("Lesson",
         jeky <- read_jekyll_episodes(path, rmd, ...)
         self$episodes <- jeky$episodes
         self$rmd <- jeky$rmd
+        self$sandpaper <- FALSE
       } else {
         episode_path <- fs::path(path, "episodes")
         extra_paths <- fs::path(path, c("instructors", "learners", "profiles"))
@@ -70,6 +80,72 @@ Lesson <- R6::R6Class("Lesson",
       self$path <- path
     },
 
+    #' @description
+    #' read in the markdown content generated from RMarkdown sources and load
+    #' load them into memory
+    load_built = function() {
+      if (self$sandpaper) {
+        self$built <- get_built_files(self)
+      } else {
+        issue_warning("Only lessons using {.pkg sandpaper} can load built files")
+      }
+      invisible(self)
+    },
+
+    #' @description
+    #' A getter for various active bindings in the [Episode] class of objects.
+    #' In practice this is syntactic sugar around 
+    #' `purrr::map(l$episodes, ~.x$element)`
+    #' 
+    #' @param element \[`character`\] a defined element from the active bindings
+    #' in the [Episode] class. Defaults to NULL, which will return nothing. 
+    #' Elements that do not exist in the [Episode] class will return NULL
+    #' @param collection \[`character`\] one or more of "episodes" (default),
+    #' "extra", or "built". Select `TRUE` to collect information from all files.
+    #' @examples
+    #' frg <- Lesson$new(lesson_fragment())
+    #' frg$get("error") # error code blocks
+    #' frg$get("links") # links
+    get = function(element = NULL, collection = "episodes") {
+      if (is.null(element)) {
+        return(NULL)
+      }
+      things <- c("episodes", "extra", "built")
+      names(things) <- things
+      things <- things[collection]
+      if (length(things) == 1L) {
+        to_collect <- self[[things]]
+      } else {
+        to_collect <- purrr::flatten(purrr::map(things, ~self[[.x]]))
+      }
+      purrr::map(to_collect, ~.x[[element]])
+    },
+    #' @description
+    #' summary of element counts in each episode. This can be useful for
+    #' assessing a broad overview of the lesson dynamics
+    #' @param collection \[`character`\] one or more of "episodes" (default),
+    #' "extra", or "built". Select `TRUE` to collect information from all files.
+    #' @examples
+    #' frg <- Lesson$new(lesson_fragment())
+    #' frg$summary() # episode summary (default)
+    summary = function(collection = "episodes") {
+      if (!self$sandpaper) {
+        issue_warning("Summary not guaranteed for styles-based lessons")
+      }
+      things <- c("episodes", "extra", "built")
+      names(things) <- things
+      things <- things[collection]
+      if (length(things) == 1L) {
+        to_collect <- self[[things]]
+      } else {
+        to_collect <- purrr::flatten(purrr::map(things, ~self[[.x]]))
+      }
+      res <- purrr::map(to_collect, ~message_muffler(.x$summary()))
+      res <- stack_rows(res)
+      names(res)[1] <- "page"
+      return(res)
+    },
+
     #' @description
     #' Gather all of the blocks from the lesson in a list of xml_nodeset objects
     #' @param body the XML body of a carpentries lesson (an xml2 object)
@@ -136,10 +212,10 @@ Lesson <- R6::R6Class("Lesson",
         if (sum(to_remove) > 0) {
           nms <- glue::glue_collapse(names(to_remove)[to_remove], sep = ", ", last = ", and ")
           epis <- if (sum(to_remove) > 1) "episodes" else "episode"
-          message(glue::glue("Removing {sum(to_remove)} {epis}: {nms}"))
+          pb_message(glue::glue("Removing {sum(to_remove)} {epis}: {nms}"))
           self$episodes[to_remove] <- NULL
         } else {
-          message("Nothing to remove!")
+          pb_message("Nothing to remove!")
         }
       } else {
         self$episodes[lengths(self$challenges()) == 0] <- NULL
@@ -231,11 +307,7 @@ Lesson <- R6::R6Class("Lesson",
       res <- purrr::map(self$episodes, 
         ~.x$validate_headings(verbose = verbose, warn = FALSE)
       )
-      if (requireNamespace("dplyr", quietly = TRUE)) {
-        res <- dplyr::bind_rows(res, .id = "episodes")
-      } else {
-        res <- do.call(rbind, res)
-      }
+      res <- stack_rows(res)
       throw_heading_warnings(res)
       invisible(res)
     },
@@ -259,11 +331,7 @@ Lesson <- R6::R6Class("Lesson",
     #' frg$validate_divs()
     validate_divs = function() {
       res <- purrr::map(self$episodes, ~.x$validate_divs(warn = FALSE))
-      if (requireNamespace("dplyr", quietly = TRUE)) {
-        res <- dplyr::bind_rows(res)
-      } else {
-        res <- do.call(rbind, res)
-      }
+      res <- stack_rows(res)
       throw_div_warnings(res)
       invisible(res)
     },
@@ -292,11 +360,7 @@ Lesson <- R6::R6Class("Lesson",
     #' frg$validate_links()
     validate_links = function() {
       res <- purrr::map(self$episodes, ~.x$validate_links(warn = FALSE))
-      if (requireNamespace("dplyr", quietly = TRUE)) {
-        res <- dplyr::bind_rows(res)
-      } else {
-        res <- do.call(rbind, res)
-      }
+      res <- stack_rows(res)
       throw_link_warnings(res)
       invisible(res)
     }

R/div.R

@@ -675,8 +675,8 @@ find_div_pairs <- function(divs, close = div_close_regex()) {
       cli::cli_alert_danger(msg1)
       stop(cli::cli_alert_danger(msg, id = names(tags)[bad]), call. = FALSE)
     } else {
-      message(msg1)
-      message(glue::glue(msg))
+      pb_message(msg1)
+      pb_message(glue::glue(msg))
       stop(names(tags)[bad], call. = FALSE)
     }
   }

R/get_built_files.R

@@ -0,0 +1,20 @@
+get_built_files <- function(lesson = ".") {
+  if (inherits(lesson, "character") && fs::dir_exists(lesson)) {
+    path <- lesson
+    lesson <- Lesson$new(path, jekyll = FALSE)
+  } else {
+    path <- lesson$path
+  }
+  if (!fs::dir_exists(fs::path(path, "site", "built"))) { 
+    txt <- "No files built. Run {.code sandpaper::build_lesson()} to build."
+    cli::cli_alert_warning(txt)
+    return(NULL)
+  } 
+  lfiles <- fs::path_file(lesson$files)
+  built_files <- fs::path(path, "site", "built", fs::path_ext_set(lfiles, "md"))
+  res <- purrr::map(built_files, 
+    ~Episode$new(.x, process_tags = FALSE, fix_liquid = FALSE, fix_links = FALSE)$confirm_sandpaper())
+
+  names(res) <- fs::path_rel(built_files, path)
+  res
+}

R/read_jekyll_episodes.R

@@ -32,7 +32,7 @@ read_jekyll_episodes <- function(path = NULL, rmd = FALSE, ...) {
   if (read_md) {
     eps <- read_markdown_files(md_src, sandpaper = FALSE, ...)
   } else if (all_rmd) {
-    message("could not find _episodes/, using _episodes_rmd/ as the source")
+    pb_message("could not find _episodes/, using _episodes_rmd/ as the source")
   } else if (md_exists && md_n == 0L) {
     stop(glue::glue("The _episodes/ directory must have (R)markdown files"),
       call. = FALSE