Check end of block, update for {tinkr} expectations, add CRON

.github/workflows/R-CMD-check.yaml

@@ -5,6 +5,8 @@ on:
   pull_request:
     branches:
       - main
+  schedule:
+    - cron: '* * 14,28 * *'
 
 name: R-CMD-check
 

R/kramdown_tags.R

@@ -90,6 +90,17 @@ set_ktag_block <- function(tags) {
     )
   )
 
+  # Sometimes, we just have to check to make sure the tag is really at the end
+  # of the block. In this case, we already know that the parent is a blockquote
+  # and we know that the parents and tags are blanaced, so here we want to 
+  # just confirm that they are the end of the block. 
+  balanced <- length(parents) == length(are_tags)
+  if (balanced) {
+    end_of_block <- get_lineend(tags) == get_lineend(parents)
+  } else {
+    end_of_block <- FALSE
+  }
+
   # exclude the first tag if it's after a code block
   # In Rmarkdown documents, all code blocks are tagged with a language attribute
   #
@@ -108,7 +119,7 @@ set_ktag_block <- function(tags) {
   }
 
 
-  if (after_code || is_language || is_output) {
+  if (!all(end_of_block) && (after_code || is_language || is_output)) {
     ctag <- children[[are_tags[1]]]
     are_tags <- are_tags[-1]
     if (after_code || is_language) {
@@ -119,11 +130,13 @@ set_ktag_block <- function(tags) {
   }
 
 
-  # Sometimes the tags are mis-aligned by the interpreter
-  # when this happens, we need to find the nested block quote and
+  # Sometimes the tags are mis-aligned by the interpreter, which will happen
+  # with the last solution block inside of a challenge block 
+  #
+  # When this happens, we need to find the nested block quote and
   # get its parents
-  if (length(parents) < length(are_tags) && length(parents) == 1) {
-    blq <- glue::glue(".//{ns}:block_quote/*")
+  if (!balanced && length(parents) < length(are_tags) && length(parents) == 1) {
+    blq <- glue::glue(".//{ns}:block_quote[not(@ktag)]/*")
     if (xml2::xml_find_lgl(parents, glue::glue("boolean({blq})"))) {
       parents <- xml2::xml_parents(
         xml2::xml_find_first(parents, blq)
@@ -165,7 +178,7 @@ set_ktag_block <- function(tags) {
     # Grab the correct parent from the list
     the_parent <- parents[tag]
     this_tag   <- xml2::xml_text(children[are_tags[tag]])
-    xml2::xml_attr(the_parent, "ktag") <-this_tag
+    xml2::xml_attr(the_parent, "ktag") <- this_tag
 
   }
   xml2::xml_remove(children[are_tags])

R/utils.R

@@ -190,16 +190,16 @@ after_thing <- function(body, thing = "code_block") {
 #' @keywords internal
 are_blocks <- function(krams) {
   tags <- c(
-    "contains(text(),'callout}')",
-    "contains(text(),'objectives}')",
-    "contains(text(),'challenge}')",
-    "contains(text(),'prereq}')",
-    "contains(text(),'checklist}')",
-    "contains(text(),'solution}')",
-    "contains(text(),'discussion}')",
-    "contains(text(),'testimonial}')",
-    "contains(text(),'keypoints}')",
-    "contains(text(),'questions}')",
+    "contains(text(),'.callout')",
+    "contains(text(),'.objectives')",
+    "contains(text(),'.challenge')",
+    "contains(text(),'.prereq')",
+    "contains(text(),'.checklist')",
+    "contains(text(),'.solution')",
+    "contains(text(),'.discussion')",
+    "contains(text(),'.testimonial')",
+    "contains(text(),'.keypoints')",
+    "contains(text(),'.questions')",
     NULL
   )
   tags <- glue::glue_collapse(tags, sep = " or ")

tests/testthat/test-conversion.R

@@ -61,7 +61,7 @@ test_that("Episodes can be converted to use sandpaper", {
   # language tags added
   expect_equal(xml2::xml_attr(e$code, "language"), c("r", langs))
   # name tags added
-  expect_match(na.omit(xml2::xml_attr(e$code, "name")), "setup|python-chunk")
+  expect_match(xml2::xml_attr(e$code, "name"), "^(setup|python-chunk-.+)*$")
   # First node is the setup chunk
   expect_equal(xml2::xml_text(xml2::xml_child(e$body)), 
     'library("reticulate")\n# Generated with {pegboard}'
@@ -86,7 +86,7 @@ test_that("Episodes can be converted to use sandpaper", {
   expect_equal(xml2::xml_attr(e$code, "ktag"), rep(NA_character_, 11))
   # but the block quotes are still there
   expect_length(e$tags, 3 + 3)
-  expect_equal(xml2::xml_attr(e$code, "name"), rep(NA_character_, 11))
+  expect_equal(xml2::xml_attr(e$code, "name"), rep("", 11))
   expect_equal(xml2::xml_attr(e$code, "language"), rep(NA_character_, 11))
   # First node is text
   expect_equal(xml2::xml_text(xml2::xml_child(e$body)), 

tests/testthat/test-get_lesson.R

@@ -207,20 +207,11 @@ test_that("Lesson methods work as expected", {
   # $n_problems ----------------------------------------------------------------
   problems <- rep(0, 8)
   names(problems) <- episodes
-  problems[4] <- 1
+  problems[4] <- 2
   expect_equal(lex$n_problems, problems)
 
   # $show_problems -------------------------------------------------------------
-  ele <- xml2::xml_find_first(
-    lex$episodes$`04-formatting.md`$body,
-    ".//d1:paragraph[d1:text[text()='do_something']]"
-  )
-  prob_expect <- list(
-    "04-formatting.md" = list(
-      code = list(list(element = ele, reason = "orphan code tag"))
-    )
-  )
-  expect_equal(lex$show_problems, prob_expect)
+  expect_length(lex$show_problems, 1)
 
   # $blocks --------------------------------------------------------------------
   # No level three blocks
@@ -272,10 +263,10 @@ test_that("Lesson methods work as expected", {
 test_that("code with embedded div tags are parsed correctly", {
 
   suppressMessages(lex <- get_lesson("carpentries/lesson-example"))
-  expect_length(lex$episodes[[4]]$get_blocks(), 11)
-  expect_length(lex$episodes[[4]]$unblock()$get_divs(), 14)
+  expect_length(lex$episodes[[4]]$get_blocks(), 12)
+  expect_length(lex$episodes[[4]]$unblock()$get_divs(), 15)
   expect_length(lex$episodes[[4]]$challenges, 1)
-  expect_length(lex$episodes[[4]]$solutions, 1)
+  expect_length(lex$episodes[[4]]$solutions, 2)
 
 })