tests/testthat/test-rd-r6.R

test_that("extract_r6_data without source refs", {
  txt <-
    "R6::R6Class(
       public = list(
         field1 = NULL,
         meth1 = function(Z) { },
         meth2 = function(Z = 10, ...) { },
         field2 = \"foobar\",
         meth3 = function() { }
       )
     )"
  C <- eval(parse(text = txt, keep.source = FALSE))
  expect_error(extract_r6_data(C), "without source references")
})

test_that("extract_r6_methods", {
  txt <-
    "R6::R6Class(
       public = list(
         field1 = NULL,
         meth1 = function(Z) { },
         meth2 = function(Z = 10, ...) { },
         field2 = \"foobar\",
         meth3 = function() { }
       )
     )"
  C <- eval(parse(text = txt, keep.source = TRUE))
  M <- extract_r6_methods(C)
  expect_equal(M$type, rep("method", 4))
  expect_equal(M$name, c(paste0("meth", 1:3), "clone"))
  expect_equal(M$line, c(4L, 5L, 7L, NA_integer_))
  expect_equal(
    M$formals,
    I(list(
      as.pairlist(alist(Z=)),
      as.pairlist(alist(Z = 10, ... = )),
      NULL,
      as.pairlist(alist(deep = FALSE))
    ))
  )
})

test_that("extract_r6_super_data", {

  eval(parse(test_path("roxygen-block-3.R"), keep.source = TRUE))

  D <- extract_r6_super_data(C)
  mypkg <- environmentName(topenv())
  expect_equal(D$classes$package, rep(mypkg, 2))
  expect_equal(D$classes$classname, c("B", "A"))
  expect_equal(D$members$package, rep(mypkg, 18))
  expect_equal(D$members$classname, rep(c("B", "A"), c(8, 10)))
  expect_equal(
    D$members$type,
    c("method", "method", "method", "field", "field", "active", "active",
      "active", "method", "method", "method", "method", "field", "field",
      "field", "active", "active", "active")
  )
  expect_equal(
    D$members$name,
    c("meth4", "meth1", "clone", "field4", "field1", "active5", "active4",
      "active1", "meth3", "meth2", "meth1", "clone", "field3", "field2",
      "field1", "active3", "active2", "active1")
  )
})

test_that("extract_r6_fields", {
  C <- R6::R6Class(
    public = list(
      field1 = NULL,
      meth1 = function() { },
      field2 = "foobar"
    )
  )
  F <- extract_r6_fields(C)
  expect_equal(F$type, rep("field", 2))
  expect_equal(F$name, c("field1", "field2"))

  C <- R6::R6Class(
    public = list(
      meth1 = function() { }
    )
  )
  F <- extract_r6_fields(C)
  expect_s3_class(F, "data.frame")
  expect_equal(F$type, character())
  expect_equal(F$name, character())

  C <- R6::R6Class()
  F <- extract_r6_fields(C)
  expect_s3_class(F, "data.frame")
  expect_equal(F$type, character())
  expect_equal(F$name, character())
})

test_that("extract_r6_bindings", {
  C <- R6::R6Class(
    active = list(
      bind1 = function(x) { },
      bind2 = function(x) { }
    ),
    public = list(
      meth1 = function() { }
    )
  )
  F <- extract_r6_bindings(C)
  expect_equal(F$type, rep("active", 2))
  expect_equal(F$name, c("bind1", "bind2"))

  C <- R6::R6Class(
    public = list(
      meth1 = function() { }
    )
  )
  F <- extract_r6_bindings(C)
  expect_s3_class(F, "data.frame")
  expect_equal(F$type, character())
  expect_equal(F$name, character())

  C <- R6::R6Class()
  F <- extract_r6_bindings(C)
  expect_s3_class(F, "data.frame")
  expect_equal(F$type, character())
  expect_equal(F$name, character())
})

test_that("r6_fields", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field field1 Foo.
    #' @field field2 Bar.
    #' @field bind1 Active binding.
    C <- R6::R6Class(
      public = list(
        field1 = NULL,
        field2 = \"foobar\"
      ),
      active = list(
        bind1 = function(x) { }
      )
    )"
  block <- parse_text(text)[[1]]
  r6data <- block_get_tag_value(block, ".r6data")
  expect_silent(doc <- r6_fields(block, r6data))

  expect_true(any(grepl("code{field1}}{Foo.", doc, fixed = TRUE)))
  expect_true(any(grepl("code{field2}}{Bar.", doc, fixed = TRUE)))
})

test_that("r6_active_bindings", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field bind1 Active binding.
    #' @field bind2 Active 2.
    C <- R6::R6Class(
      public = list(
        field1 = NULL,
        field2 = \"foobar\"
      ),
      active = list(
        bind1 = function(x) { },
        bind2 = function(x) { }
      )
    )"
  block <- parse_text(text)[[1]]
  r6data <- block_get_tag_value(block, ".r6data")
  expect_silent(doc <- r6_active_bindings(block, r6data))

  expect_true(any(grepl("code{bind1}}{Active binding.", doc, fixed = TRUE)))
  expect_true(any(grepl("code{bind2}}{Active 2.", doc, fixed = TRUE)))
})

test_that("R6 edge cases, class without methods", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field field1 Field.
    #' @field field2 Another field.
    #' @field bind1 Active binding.
    #' @field bind2 Active 2.
    C <- R6::R6Class(
      cloneable = FALSE,
      public = list(
        field1 = NULL,
        field2 = \"foobar\"
      ),
      active = list(
        bind1 = function(x) { },
        bind2 = function(x) { }
      )
    )"
  block <- parse_text(text)[[1]]
  rd <- RoxyTopic$new()

  expect_silent(topic_add_r6_methods(rd, block, environment()))
  expect_false(grepl("method", format(rd), ignore.case = TRUE))
})

test_that("R6 edge cases, class without (documented) fields", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field bind1 Active binding.
    #' @field bind2 Active 2.
    C <- R6::R6Class(
      public = list(
      ),
      active = list(
        bind1 = function(x) { },
        bind2 = function(x) { }
      )
    )"
  block <- parse_text(text)[[1]]
  rd <- RoxyTopic$new()

  expect_silent(topic_add_r6_methods(rd, block, environment()))
  expect_false(grepl("field", format(rd), ignore.case = TRUE))

  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field bind1 Active binding.
    #' @field bind2 Active 2.
    C <- R6::R6Class(
      public = list(
        undocumented_field = NULL
      ),
      active = list(
        bind1 = function(x) { },
        bind2 = function(x) { }
      )
    )"
  block <- parse_text(text)[[1]]
  rd <- RoxyTopic$new()

  expect_warning(topic_add_r6_methods(rd, block, environment()))
  expect_false(grepl("field", format(rd), ignore.case = TRUE))
})

test_that("R6 edge cases, class without active bindings", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field field1 Field.
    #' @field field2 Another field.
    C <- R6::R6Class(
      public = list(
        field1 = NULL,
        field2 = \"foobar\"
      ),
      active = list(
      )
    )"
  block <- parse_text(text)[[1]]
  rd <- RoxyTopic$new()

  expect_silent(topic_add_r6_methods(rd, block, environment()))
  expect_false(grepl("active", format(rd), ignore.case = TRUE))
})

test_that("R6 edge cases, class without anything", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    C <- R6::R6Class(
      cloneable = FALSE,
      public = list(
      ),
      active = list(
      )
    )"
  block <- parse_text(text)[[1]]
  rd <- RoxyTopic$new()

  expect_silent(topic_add_r6_methods(rd, block, environment()))
  doc <- format(rd)
  expect_false(grepl("method", format(rd), ignore.case = TRUE))
  expect_false(grepl("field", format(rd), ignore.case = TRUE))
  expect_false(grepl("active", format(rd), ignore.case = TRUE))
})

test_that("warning if no method comes after the docs", {
  text <- "
    #' @title Title
    #' @description Description.
    #' @details Details.
    #' @field field1 Yep.
    C <- R6::R6Class(
      public = list(
        #' @description Method 1.
        method1 = function() { },
        #' @description Dangling.
        field1 = NULL
      )
    )"

  eval(parse(text = text, keep.source = TRUE))
  block <- parse_text(text, env = environment())[[1]]
  rd <- RoxyTopic$new()

  expect_warning(
    topic_add_r6_methods(rd, block, environment()),
    "Cannot find matching R6 method"
  )
  doc <- format(rd)
})

test_that("integration test", {

  wd <- getwd()
  on.exit(setwd(wd), add = TRUE)
  setwd(test_path())

  env <- new.env(parent = asNamespace("roxygen2"))
  eval(
    parse(test_path("roxygen-block-3.R"), keep.source = TRUE),
    envir = env
  )

  blocks <- parse_file(test_path("roxygen-block-3.R"), env = env)

  roc <- roclet_preprocess(roclet_find("rd"))

  roxy_warnings <- character()

  withCallingHandlers(
    res <- roclet_process(roc, blocks = blocks, env = env, base_path = test_path()),
    warning = function(w) {
      roxy_warnings <<- c(roxy_warnings, w$message)
      invokeRestart("muffleWarning")
    }
  )

  # Warnings
  verify_output(
    test_path(paste0("roxygen-block-3-warnings.txt")),
    sort(roxy_warnings)
  )

  tmp <- tempfile()
  on.exit(unlink(tmp), add = TRUE)
  for (n in names(res)) {
    path <- test_path(paste0("roxygen-block-3-", n))
    verify_output(path, res[[n]])
    cat(format(res[[n]]), file = tmp)
    expect_silent(chk <- tools::checkRd(tmp))
    expect_equal(length(chk), 0L)
  }
})

test_that("r6 option", {
  text <- "
    #' @title Title
    #' @description Description.
    C <- R6::R6Class(
      public = list(
        field = NULL,
        #' @description Method desc.
        #' @param arg Method arg.
        meth = function(arg) { }
      )
    )"
  old <- roxy_meta_get("r6")
  on.exit(roxy_meta_set("r6", old), add = TRUE)
  roxy_meta_set("r6", FALSE)

  expect_silent(
    out <- roc_proc_text(rd_roclet(), text)
  )
  rd <- format(out$C.Rd)
  expect_false(grepl("section{Methods}", rd, fixed = TRUE))
  expect_true(grepl("arguments{", rd, fixed = TRUE))
})

Try the roxygen2 package in your browser

Any scripts or data that you put into this service are public.

roxygen2 documentation built on Sept. 8, 2021, 9:08 a.m.