R/slide_timing.R

# Pattern matching timing comments, e.g. <!-- MK 00:30 --> or just <!-- 00:30 -->
timing_comment_pattern <- paste0(
  "<!--[[:space:]]*(?:([[:alnum:]._-]+)[[:space:]]+)?",
  "([0-9]+(?::[0-9]{2}){0,2})[[:space:]]*-->"
)

parse_duration_seconds <- function(x) {
  vapply(x, function(t) {
    parts <- strsplit(t, ":", fixed = TRUE)[[1]]
    parts <- suppressWarnings(as.numeric(parts))
    if (length(parts) == 0 || length(parts) > 3 || anyNA(parts)) {
      return(NA_real_)
    }
    multipliers <- c(3600, 60, 1)[(4 - length(parts)):3]
    sum(parts * multipliers)
  }, numeric(1), USE.NAMES = FALSE)
}

format_seconds <- function(x) {
  x <- round(x)
  h <- floor(x / 3600)
  m <- floor((x %% 3600) / 60)
  s <- x %% 60
  ifelse(h > 0, sprintf("%d:%02d:%02d", h, m, s), sprintf("%d:%02d", m, s))
}

# Extract all timing comments from a character vector (one line per element).
# Returns a data frame with columns line (1-based index), speaker (NA for
# comments without a speaker code), duration, and seconds.
extract_timing_comments <- function(lines) {
  matches <- regmatches(lines, regexec(timing_comment_pattern, lines))
  hits <- which(lengths(matches) > 0)
  if (length(hits) == 0) {
    return(data.frame(
      line = integer(), speaker = character(), duration = character(),
      seconds = numeric()
    ))
  }
  speaker <- trimws(vapply(matches[hits], `[[`, character(1), 2))
  speaker[speaker == ""] <- NA_character_
  data.frame(
    line = hits,
    speaker = speaker,
    duration = vapply(matches[hits], `[[`, character(1), 3),
    seconds = parse_duration_seconds(vapply(matches[hits], `[[`, character(1), 3)),
    stringsAsFactors = FALSE
  )
}

# Assign each timing comment to the slide it belongs to. A comment belongs to
# the slide whose heading most recently appeared before it; content before the
# first heading belongs to the title slide.
assign_slides <- function(lines, comments, slide_level) {
  headings <- grepl(paste0("^#{1,", slide_level, "}[[:space:]]"), lines)
  slide_of_line <- cumsum(headings)
  comments$slide <- slide_of_line[comments$line]
  titles <- trimws(sub("^#+[[:space:]]+", "", lines[headings]))
  c("(title)", titles)[comments$slide + 1]
}

#' Compute per-speaker slide times from timing comments
#'
#' Parses an R Markdown presentation for timing comments of the form
#' `<!-- MK 00:30 -->` (speaker code followed by a duration in `MM:SS`,
#' `HH:MM:SS`, or plain seconds format) or, for single-speaker talks, simply
#' `<!-- 00:30 -->`, and computes the time allocated to each slide, each
#' speaker, and the whole presentation.
#'
#' The same convention can be used directly in
#' [revealjs_presentation()]: any such comment in the source document is
#' automatically converted into a `data-timing` attribute on the enclosing
#' slide's `<section>` element, which activates the pacing timer in the
#' reveal.js speaker view.
#'
#' @param input Path to an R Markdown file.
#' @param slide_level Level of heading that denotes individual slides (should
#'   match the `slide_level` used when rendering).
#'
#' @return A list with three elements: `slides` (one row per slide and
#'   speaker), `speakers` (total time per speaker), and `total` (grand total
#'   in seconds). `slide_timing()` is called for its side effect of printing a
#'   summary.
#'
#' @examples
#' \dontrun{
#' slide_timing("talk.Rmd")
#' }
#'
#' @importFrom stats aggregate
#' @export
slide_timing <- function(input, slide_level = 2) {
  lines <- readLines(input, warn = FALSE)
  comments <- extract_timing_comments(lines)
  if (nrow(comments) == 0) {
    message("No timing comments found in ", input)
    return(invisible(NULL))
  }
  comments$slide_title <- assign_slides(lines, comments, slide_level)
  comments$speaker <- timing_speaker_label(comments$speaker)

  by_speaker <- aggregate(seconds ~ speaker, comments, FUN = sum)
  total <- sum(comments$seconds)
  show_speakers <- any(comments$speaker != "(unnamed)")

  cat("Slide timing for", basename(input), "\n\n")
  if (show_speakers) {
    per_slide <- aggregate(seconds ~ slide_title + speaker, comments, FUN = sum)
  } else {
    per_slide <- aggregate(seconds ~ slide_title, comments, FUN = sum)
  }
  print(data.frame(
    slide = per_slide$slide_title,
    speaker = if (show_speakers) per_slide$speaker else NULL,
    time = format_seconds(per_slide$seconds),
    stringsAsFactors = FALSE
  ))
  cat("\n")
  named_speakers <- by_speaker[by_speaker$speaker != "(unnamed)", , drop = FALSE]
  if (nrow(named_speakers) > 0) {
    print(
      data.frame(
        speaker = c(named_speakers$speaker, "total"),
        time = format_seconds(c(named_speakers$seconds, total)),
        stringsAsFactors = FALSE
      ),
      row.names = FALSE
    )
  } else {
    cat("total time:", format_seconds(total), "\n")
  }

  invisible(list(slides = comments[, c("slide_title", "speaker", "duration", "seconds")],
                 speakers = by_speaker, total = total))
}

# Display label for unnamed speakers
timing_speaker_label <- function(speaker) {
  ifelse(is.na(speaker), "(unnamed)", speaker)
}

# Timing comments and ::: notes blocks written before the first heading do
# not land on the title slide: pandoc puts them into an otherwise empty
# phantom slide right after it. Merge such a phantom slide -- consisting of
# nothing but notes, timing comments, and whitespace -- into the title
# slide, so that notes and timing can be given for the title as well.
merge_title_slide_notes <- function(lines) {
  title_open <- grep('<section class="title-frame"', lines)
  if (length(title_open) == 0) {
    return(lines)
  }
  title_open <- title_open[1]
  title_close <- which(lines == "</section>")
  title_close <- title_close[title_close > title_open][1]

  phantom_open <- grep("^<section", lines)
  phantom_open <- phantom_open[phantom_open > title_close][1]
  if (is.na(phantom_open)) {
    return(lines)
  }
  phantom_close <- which(lines == "</section>")
  phantom_close <- phantom_close[phantom_close > phantom_open][1]

  inner <- lines[(phantom_open + 1):(phantom_close - 1)]

  # the phantom slide is only merged if it has no visible content beyond
  # notes, timing comments, and whitespace
  aside <- grep('<aside class="notes">', inner)
  aside_end <- grep("</aside>", inner)
  in_aside <- if (length(aside) > 0) {
    unlist(Map(":", aside, aside_end[aside_end > aside][1]))
  }
  content <- seq_along(inner)
  content <- content[!inner %in% ""]
  content <- setdiff(content, c(grep("<!--", inner), in_aside))
  if (length(content) > 0) {
    return(lines)
  }

  moved <- inner[nzchar(trimws(inner))]
  append(
    lines[-(phantom_open:phantom_close)],
    moved,
    after = title_close - 1
  )
}

# Convert timing comments into data-timing attributes on the enclosing
# <section> elements of a rendered reveal.js HTML document. Returns the
# modified lines invisibly along with the extracted comments as attributes.
apply_timing_attributes <- function(lines) {
  comments <- extract_timing_comments(lines)
  if (nrow(comments) == 0) {
    return(invisible(structure(lines, comments = comments)))
  }

  section_lines <- grep("^<section[^>]*>", lines)
  section_of_comment <- findInterval(comments$line, section_lines)
  ok <- section_of_comment > 0
  if (!all(ok)) {
    warning(
      "Ignoring ", sum(!ok), " timing comment(s) outside any <section>",
      call. = FALSE
    )
    comments <- comments[ok, , drop = FALSE]
    section_of_comment <- section_of_comment[ok]
  }

  per_section <- tapply(comments$seconds, section_of_comment, sum)

  for (idx in names(per_section)) {
    target <- section_lines[as.integer(idx)]
    lines[target] <- sub(
      "^(<section[^>]*?)(/?>)$",
      sprintf('\\1 data-timing="%d"\\2', round(per_section[[idx]])),
      lines[target]
    )
  }

  invisible(structure(lines, comments = comments))
}

# Activate the pacing timer of the notes plugin by injecting the total time
# planned with the timing comments into the reveal.js configuration. Without
# a totalTime or defaultTiming config value, the speaker view does not show
# any pacing information at all.
inject_total_time <- function(lines, seconds) {
  # only respect explicitly configured pacing values, not e.g. the
  # unconditional "defaultTiming: null" emitted by the pandoc template
  pacing <- grep("\\b(totalTime|defaultTiming)\\s*:", lines, value = TRUE)
  if (any(!grepl(":\\s*(null|0|false|\"\"|'')\\s*,?\\s*$", trimws(pacing)))) {
    return(lines)
  }
  init <- grep("Reveal\\.initialize\\(\\s*\\{", lines)
  if (length(init) == 0) {
    return(lines)
  }
  append(
    lines,
    sprintf("\t\t\ttotalTime: %d,", round(seconds)),
    after = init[[1]]
  )
}

timing_report_message <- function(comments) {
  comments$speaker <- timing_speaker_label(comments$speaker)
  by_speaker <- aggregate(seconds ~ speaker, comments, FUN = sum)
  total <- sum(comments$seconds)
  named <- by_speaker[by_speaker$speaker != "(unnamed)", , drop = FALSE]
  unnamed <- by_speaker[by_speaker$speaker == "(unnamed)", , drop = FALSE]
  parts <- c(
    # note: paste0() would treat a zero-length data frame column as "",
    # so only build these strings when there is something to report
    if (nrow(named) > 0) paste0(named$speaker, ": ", format_seconds(named$seconds)),
    if (nrow(unnamed) > 1 || (nrow(unnamed) == 1 && nrow(named) > 0)) {
      paste0("(unnamed): ", format_seconds(unnamed$seconds))
    }
  )
  if (length(parts) > 0) {
    sprintf(
      "Slide timing -- %s -- total %s",
      paste(parts, collapse = ", "),
      format_seconds(total)
    )
  } else {
    sprintf("Slide timing -- total %s", format_seconds(total))
  }
}