tests/testthat/helper-dev.R

In rstats-db/DBI: R Database Interface

if (dir.exists("../../../RSQLite")) {
  writeLines(
    c(
      "# Generated by helper-dev.R, do not edit by hand",
      "",
      "skip_if_not_installed(\"RSQLite\")",
      "skip_if_not_installed(\"nanoarrow\")",
      "",
      "# helper-DBItest.R",
      readLines("../../../RSQLite/tests/testthat/helper-DBItest.R"),
      "",
      "# test-DBItest.R",
      readLines("../../../RSQLite/tests/testthat/test-DBItest.R")
    ),
    "test-DBItest.R"
  )
}

if (Sys.getenv("CI") == "") {
  r <- rprojroot::is_r_package$make_fix_file()

  rd_db <- tools::Rd_db(dir = r())

  Links <- tools::findHTMLlinks()

  html_topic <- function(name) {
    rd <- rd_db[[paste0(name, ".Rd")]]

    conn <- textConnection(NULL, "w")
    on.exit(close(conn))

    # tools::Rd2HTML(rd, conn, Links = Links)
    tools::Rd2HTML(rd, conn)

    textConnectionValue(conn)
  }

  create_xml_topic <- function(name, patcher) {
    html <- html_topic(name)
    x <- xml2::read_html(paste(html, collapse = "\n"))

    # No idea why this is necessary when embedding HTML in Markdown
    codes <- x %>% xml2::xml_find_all("//code[contains(., '$')]")
    xml2::xml_text(codes) <- gsub("[$]", "\\\\$", xml2::xml_text(codes))

    xx <- x %>% xml2::xml_find_first("/html/body")
    xx %>% xml2::xml_find_first("//table") %>% xml2::xml_remove()
    xx %>% xml2::xml_find_all("//pre") %>% xml2::xml_set_attr("class", "r")
    patcher(xx)
  }

  patch_package_doc <- function(x) {
    x %>%
      xml2::xml_find_first("//h3") %>%
      xml2::xml_remove()

    remove_see_also_section(x)
    remove_authors_section(x)

    x %>%
      xml2::xml_find_first("div") %>%
      xml2::xml_children() %>%
      as.list()
  }

  move_contents_of_usage_section <- function(x) {
    # https://stackoverflow.com/a/3839299/946850
    usage_contents <-
      x %>%
      xml2::xml_find_all(
        "//h3[.='Usage']/following-sibling::node() [not(self::h3)] [count(preceding-sibling::h3)=2]")

    usage_text <-
      usage_contents %>%
      xml2::xml_find_first("//pre") %>%
      xml2::xml_text()

    h3 <- x %>% xml2::xml_find_first("//h3")

    intro_text <-
      xml2::read_xml(
        paste0(
          "<p>This section describes the behavior of the following method",
          if (length(grep("[(]", strsplit(usage_text, "\n")[[1]])) > 1) "s" else "",
          ":</p>")
      )

    xml2::xml_add_sibling(
      h3,
      intro_text,
      .where = "before")
    lapply(usage_contents, xml2::xml_add_sibling, .x = h3, .copy = FALSE, .where = "before")

    x %>% xml2::xml_find_first("//h3[.='Usage']") %>% xml2::xml_remove()
    x
  }

  move_additional_arguments_section <- function(x) {
    # https://stackoverflow.com/a/3839299/946850 and some trial and error
    additional_arguments <- x %>%
      xml2::xml_find_all(
        "//h3[.='Additional arguments'] | //h3[.='Additional arguments']/following-sibling::node()[following-sibling::h3]")

    after_arg <- x %>% xml2::xml_find_first("//h3[text()='Arguments']/following-sibling::h3")

    lapply(additional_arguments, xml2::xml_add_sibling, .x = after_arg, .copy = FALSE, .where = "before")

    x
  }

  patch_lifecycle_badges <- function(x) {
    img <-
      x %>% xml2::xml_find_all("//img[@src='../help/figures/lifecycle-experimental.svg']")

    xml2::xml_set_attr(img, "src", "https://dbi.r-dbi.org/reference/figures/lifecycle-experimental.svg")
  }

  remove_see_also_section <- function(x) {
    # https://stackoverflow.com/a/3839299/946850 and some trial and error
    x %>%
      xml2::xml_find_all(
        "//h3[.='See Also'] | //h3[.='See Also']/following-sibling::node()[following-sibling::h3]") %>%
      xml2::xml_remove()
    x
  }

  remove_authors_section <- function(x) {
    # https://stackoverflow.com/a/3839299/946850 and some trial and error
    x %>%
      xml2::xml_find_all(
        "//h3[.='Author(s)'] | //h3[.='Author(s)']/following-sibling::node()[following-sibling::h3]") %>%
      xml2::xml_remove()
    x
  }

  patch_method_doc <- function(x) {
    move_contents_of_usage_section(x)
    remove_see_also_section(x)
    move_additional_arguments_section(x)
    patch_lifecycle_badges(x)

    x %>%
      xml2::xml_find_first("div") %>%
      xml2::xml_children()
  }

  topics <- c(
    "dbDataType",
    "dbConnect",
    "dbDisconnect",
    "dbSendQuery",
    "dbFetch",
    "dbClearResult",
    "dbBind",
    "dbGetQuery",
    "dbSendStatement",
    "dbExecute",
    "dbQuoteString",
    "dbQuoteIdentifier",
    "dbReadTable",
    "dbWriteTable",
    "dbListTables",
    "dbExistsTable",
    "dbRemoveTable",
    "dbListFields",
    "dbIsValid",
    "dbHasCompleted",
    "dbGetStatement",
    "dbGetRowCount",
    "dbGetRowsAffected",
    "dbColumnInfo",
    "transactions",
    "dbWithTransaction",
    "dbGetInfo",
    NULL
  )

  xml <- c(
    list(create_xml_topic("DBI-package", patcher = patch_package_doc)),
    lapply(topics, create_xml_topic, patcher = patch_method_doc)
  )

  html <- unlist(lapply(xml, as.character))

  temp_html <- r("vignettes/spec.html")
  temp_md <- r("vignettes/spec.md")

  # temp_html <- "out.html"
  # temp_md <- "out.md"

  # html <- '<html><body><pre class="r">\na\nb\n</pre></body></html>'

  writeLines(html, temp_html)
  rmarkdown::pandoc_convert(temp_html, "gfm", verbose = FALSE, output = temp_md)
  writeLines(readLines(temp_md), temp_md)
}