R/available_tutorials.R

In learnr: Interactive Tutorials for R

#' List available tutorials
#'
#' List the tutorials that are currently available via installed R packages.
#' Or list the specific tutorials that are contained within a given R package.
#'
#' @param package Name of package
#'
#' @return `available_tutorials()` returns a `data.frame` containing "package",
#'   "name", "title", "description", "package_dependencies", "private", and
#'   "yaml_front_matter".
#'
#' @examples
#' available_tutorials(package = "learnr")
#'
#' @export
available_tutorials <- function(package = NULL) {

  info <-
    if (is.null(package)) {
      all_available_tutorials()
    } else {
      available_tutorials_for_package(package)
    }

  if (!is.null(info$error)) {
    stop.(info$error)
  }

  tutorials <- info$tutorials

  # return a data frame of tutorial pkg, name, and title
  return(tutorials)
}


#' @return will return a list of `error` and `tutorials`.
#'   `tutorials` is a \code{data.frame} containing
#'    "package": name of package; string
#'    "name": Tutorial directory. (can be passed in as `run_tutorial(NAME, PKG)`; string
#'    "title": Tutorial title from yaml header; [NA]
#'    "description": Tutorial description from yaml header; [NA]
#'    "package_dependencies": Packages needed to run tutorial; [lsit()]
#'    "private": Boolean describing if tutorial should be indexed / displayed; [FALSE]
#'    "yaml_front_matter": list column of all yaml header info; [list()]
#' @noRd
available_tutorials_for_package <- function(package) {

  an_error <- function(...) {
    list(
      tutorials = NULL,
      error = paste0(...)
    )
  }

  if (!file.exists(
    system.file(package = package)
  )) {
    return(an_error(
      "No package found with name: \"", package, "\""
    ))
  }

  tutorials_dir <- system.file("tutorials", package = package)
  if (!file.exists(tutorials_dir)) {
    return(an_error(
      "No tutorials found for package: \"", package, "\""
    ))
  }

  tutorial_folders <- list.dirs(tutorials_dir, full.names = TRUE, recursive = FALSE)
  names(tutorial_folders) <- basename(tutorial_folders)
  rmd_info <- lapply(tutorial_folders, function(tut_dir) {
    dir_rmd_file <- run_find_tutorial_rmd(tut_dir)
    if (length(dir_rmd_file) == 0) {
      return(NULL)
    }
    dir_rmd_file <- file.path(tut_dir, dir_rmd_file)
    yaml_front_matter <- rmarkdown::yaml_front_matter(dir_rmd_file)
    data.frame(
      package = package,
      name = basename(tut_dir),
      title = yaml_front_matter$title %||% NA,
      description = yaml_front_matter$description %||% NA,
      private = yaml_front_matter$private %||% FALSE,
      package_dependencies = I(list(tutorial_dir_package_dependencies(tut_dir))),
      yaml_front_matter = I(list(yaml_front_matter)),
      stringsAsFactors = FALSE,
      row.names = FALSE
    )
  })

  has_no_rmd <- vapply(rmd_info, is.null, logical(1))
  if (all(has_no_rmd)) {
    return(an_error(
      "No tutorial .Rmd files found for package: \"", package, "\""
    ))
  }

  rmd_info <- rmd_info[!has_no_rmd]

  tutorials <- do.call(rbind, rmd_info)
  class(tutorials) <- c("learnr_available_tutorials", class(tutorials))
  rownames(tutorials) <- NULL

  list(
    tutorials = tutorials,
    error = NULL
  )
}

#' @return will return a list of `error` and `tutorials` which is a \code{data.frame} containing "package", "name", and "title".
#'
#' @importFrom utils installed.packages
#' @noRd
all_available_tutorials <- function() {
  ret <- list()
  all_pkgs <- installed.packages()[,"Package"]

  for (pkg in all_pkgs) {
    info <- available_tutorials_for_package(pkg)
    if (!is.null(info$tutorials)) {
      ret[[length(ret) + 1]] <- info$tutorials
    }
  }

  # do not check for size 0, as learnr contains tutorials.

  tutorials <- do.call(rbind, ret)

  list(
    tutorials = tutorials, # will maintain class
    error = NULL
  )
}


get_tutorial_path <- function(name, package) {

  tutorial_path <- system.file("tutorials", name, package = package)

  # validate that it's a direcotry
  if (!utils::file_test("-d", tutorial_path)) {
    tutorials <- available_tutorials(package)
    possible_tutorials <- tutorials$name
    msg <- paste0("Tutorial \"", name, "\" was not found in the \"", package, "\" package.")
    # if any tutorial names are _close_ tell the user
    adist_vals <- utils::adist(possible_tutorials, name, ignore.case = TRUE)
    if (any(adist_vals <= 3)) {
      best_match <- possible_tutorials[which.min(adist_vals)]
      msg <- paste0(
        msg, "\n",
        "Did you mean \"", best_match, "\"?"
      )
    }
    stop.(msg, "\n", format(tutorials))
  }

  tutorial_path
}

#' @export
format.learnr_available_tutorials <- function(x, ...) {
  tutorials <- x
  ret <- "Available tutorials:"

  tutorials <- tutorials[!tutorials$private, , drop = FALSE]

  for (pkg in unique(tutorials$package)) {
    tutorials_sub <- tutorials[tutorials$package == pkg, , drop = FALSE]

    tutorial_names <- format(tutorials_sub$name)
    txts <- mapply(
      tutorial_names,
      tutorials_sub$title,
      SIMPLIFY = FALSE,
      FUN = function(name, title) {
        txt <- paste0("  - ", name)
        if (!is.na(title)) {
          txt <- paste0(txt, " : \"", title, "\"")
        }
        width <- getOption("width", 80)
        if (nchar(txt) > width) {
          txt <- paste0(substr(txt, 1, width - 3), "...")
        }
        txt
      }
    )

    ret <- paste0(
      ret, "\n",
      "* ", pkg, "\n",
      paste0(txts, collapse = "\n")
    )
  }

  ret
}


#' @export
print.learnr_available_tutorials <- function(x, ...) {
  cat(format(x, ...), "\n")
}