Added functionality to document R6classes using docblocks that allow …

DESCRIPTION

@@ -3,7 +3,7 @@ Title: In-Source Documentation for R
 Description: A 'Doxygen'-like in-source documentation system
     for Rd, collation, and 'NAMESPACE' files.
 URL: https://github.com/klutometis/roxygen
-Version: 5.0.1.9000
+Version: 5.0.1.9001
 License: GPL (>= 2)
 Authors@R: c(
     person("Hadley", "Wickham",, "[email protected]", c("aut", "cre", "cph")),
@@ -41,6 +41,7 @@ Collate:
     'order-params.R'
     'parse-preref.R'
     'parse.R'
+    'r6.R'
     'rc.R'
     'rd-escape.R'
     'rd-file-api.R'
@@ -64,4 +65,4 @@ Collate:
     'usage.R'
     'util-locale.R'
     'utils.R'
-RoxygenNote: 5.0.1
+RoxygenNote: 5.0.1.9001

NAMESPACE

@@ -12,6 +12,8 @@ S3method(default_export,s4class)
 S3method(default_export,s4generic)
 S3method(default_export,s4method)
 S3method(default_topic_name,default)
+S3method(default_topic_name,r6class)
+S3method(default_topic_name,r6method)
 S3method(default_topic_name,rcclass)
 S3method(default_topic_name,rcmethod)
 S3method(default_topic_name,s4class)
@@ -20,6 +22,7 @@ S3method(default_usage,"NULL")
 S3method(default_usage,"function")
 S3method(default_usage,data)
 S3method(default_usage,default)
+S3method(default_usage,r6class)
 S3method(default_usage,rcclass)
 S3method(default_usage,s3generic)
 S3method(default_usage,s3method)
@@ -47,6 +50,7 @@ S3method(format,minidesc_tag)
 S3method(format,name_tag)
 S3method(format,note_tag)
 S3method(format,param_tag)
+S3method(format,r6methods_tag)
 S3method(format,rawRd_tag)
 S3method(format,rcmethods_tag)
 S3method(format,rd_file)
@@ -69,6 +73,8 @@ S3method(merge,section_tag)
 S3method(names,rd_file)
 S3method(obj_type,"function")
 S3method(obj_type,MethodDefinition)
+S3method(obj_type,R6ClassGenerator)
+S3method(obj_type,R6MethodDef)
 S3method(obj_type,classRepresentation)
 S3method(obj_type,default)
 S3method(obj_type,genericFunction)

R/object.R

@@ -9,11 +9,18 @@
 #' @export
 #' @keywords internal
 object <- function(value, alias = NULL, type = obj_type(value)) {
+    methods_any <- NULL
+    if(type=="rcclass") {
+        methods_any <- rc_methods(value)
+    }
+    if(type=="r6class") {
+        methods_any <- r6_methods(value)
+    }
   structure(
     list(
       alias = alias,
       value = value,
-      methods = if (type == "rcclass") rc_methods(value)
+      methods = methods_any
     ),
     class = c(type, "object")
   )
@@ -23,7 +30,9 @@ default_name.s4class <-   function(x) x$value@className
 default_name.s4generic <- function(x) x$value@generic
 default_name.s4method <-  function(x) x$value@generic
 default_name.rcclass <-   function(x) x$value@className
+default_name.r6class <-   function(x) x$value@className
 default_name.rcmethod <-  function(x) x$value@name
+default_name.r6method <-  function(x) x$value@name
 default_name.s3generic <- function(x) browser()
 default_name.s3method <-  function(x) attr(x$value, "s3method")
 default_name.function <-   function(x) x$alias
@@ -105,9 +114,17 @@ obj_type.MethodDefinition <- function(x) "s4method"
 
 #' @export
 obj_type.refClassRepresentation <- function(x) "rcclass"
+
+#' @export
+obj_type.R6ClassGenerator <- function(x) "r6class"
+
 #' @export
 obj_type.refMethodDef <- function(x) "rcmethod"
 
+#' @export
+obj_type.R6MethodDef <- function(x) "r6method"
+
+
 #' @export
 obj_type.function <- function(x) "function"
 #' @export

R/r6.R

@@ -0,0 +1,135 @@
+# Extract all methods from an RC definition, returning a list of "objects".
+r6_methods <- function(obj) {
+  stopifnot(methods::is(obj, "R6ClassGenerator"))
+
+  methods_public <- obj$public_methods
+  methods_active <- obj$active
+
+  ## of the public methods, the initialize method will be renamed to "new"
+  if(any(names(methods_public) == "initialize")) {
+      names(methods_public)[which(names(methods_public) == "initialize")] <- "new"
+  }
+
+  ## add the metadata
+  for(i in seq_along(methods_public)) {
+      methods_public[[i]] <- add_r6_metadata(methods_public[[i]], name=names(methods_public)[i], class=class(obj), is_active=FALSE)
+  }
+  for(i in seq_along(methods_active)) {
+      methods_active[[i]] <- add_r6_metadata(methods_active[[i]], name=names(methods_active)[i], class=class(obj), is_active=TRUE)
+  }
+
+
+  methods_obj <- lapply(c(methods_public, methods_active), object)
+  return(methods_obj)
+}
+
+add_r6_metadata <- function(val, name, class, is_active) {
+  class(val) <- c("r6method", "function")
+  attr(val, "r6class") <- class
+  attr(val, "r6method") <- name
+  attr(val, "r6is_active") <- is_active
+
+  val
+}
+
+
+
+# Modified from docstring - a function has a doc block
+# if it's a call to {, with more than 1 element, and the first element is
+# a character vector.
+docblock <- function(f) {
+  stopifnot(is.function(f))
+  if (is.primitive(f)) return(NULL)
+
+  b <- body(f)
+  if (length(b) <= 2 || !identical(b[[1]], quote(`{`))) return(NULL)
+
+  first <- b[[2]]
+  if (!is.character(first)) return(NULL)
+
+  ## now get all the elements that are character vectors until there are no more
+  element_is_character <- unlist(lapply(b, is.character))
+  if(!all(element_is_character[-1])) {
+      last_block_line <- min(which(!element_is_character[-1]))
+  }
+  else {
+      last_block_line <- length(b)
+  }
+
+  ## now we need some more processing
+  ## first standardize so that no empty lines exist
+  block <- unlist(as.list(b)[2:last_block_line])
+
+  ## make it into one character string, then split on empty lines into sub-blocks
+  block_one_line <- paste(block, collapse="\n")
+  ## Strip off trailing and leading blank lines:
+  block_one_line <- gsub("^\n+|\n+$", "", block_one_line)
+
+  subblocks <- strsplit(block_one_line, split="\n\\s*\n[\n\\s]*", perl=TRUE, fixed=FALSE)[[1]]
+
+  param_lines <- unlist(lapply(subblocks, extract_param_from_block))
+  blocks_nonparam <- lapply(subblocks, extract_nonparam_from_block)
+  ## remove empty blocks
+  blocks_nonparam <- blocks_nonparam[unlist(lapply(blocks_nonparam, length)) > 0]
+
+  ## if there are any param_lines, make a describe block
+  if(length(param_lines) > 0) {
+      param_beginning <- "\\strong{Parameters:}\n\\describe{"
+      param_ending <- "}"
+      item_lines <- unlist(lapply(param_lines, paramline_to_item))
+      param_block <- paste(c(param_beginning, item_lines, param_ending), collapse="\n")
+  }
+  else {
+      param_block <- character(0)
+  }
+
+  return(paste(c(blocks_nonparam, param_block), collapse="\n\n"))
+}
+
+## assumption is that block has no empty lines
+extract_param_from_block <- function(block) {
+    block_split <- strsplit(block, split="[\\s\n]*@param\\s+", perl=TRUE, fixed=FALSE)[[1]]
+    if(length(block_split) == 1) {
+        return(NULL)
+    }
+    else {
+        return(block_split[-1])
+    }
+}
+
+## assumption is that block has no empty lines
+extract_nonparam_from_block <- function(block) {
+    block_nonparam <- strsplit(block, split="[\\s\n]*@param\\s+", perl=TRUE, fixed=FALSE)[[1]][1]
+    if(block_nonparam=="") {
+        return(NULL)
+    }
+    else {
+        return(block_nonparam)
+    }
+}
+
+paramline_to_item <- function(line) {
+    ## strip starting whitespace
+    line <- gsub("^\\s+", "", line, perl=TRUE)
+
+    ## split off the first word
+    first_space <- regexpr("\\s", line, perl=TRUE)
+    if(first_space==-1) { # no hit
+        first_word <- line
+        remaining <- ""
+    }
+    else {
+        first_space_len <- attr(first_space, "match.length")
+        first_word <- substr(line, start=1, stop=first_space-1)
+        remaining <- substr(line, start=first_space + first_space_len, stop=nchar(line))
+    }
+
+    ## check that remaining is rdComplete
+    if(!rdComplete(first_word)) {
+        stop(paste("Not Rd complete:", first_word))
+    }
+    if(!rdComplete(remaining)) {
+        stop(paste("Not Rd complete:", remaining))
+    }
+    return(paste0("\\item{", first_word, "}{", remaining, "}"))
+}

R/rd-file-api.R

@@ -25,7 +25,7 @@ format.rd_file <- function(x, ...) {
   tags <- as.list(x[[1]])
   order <- c("backref", "docType", "encoding", "name", "alias", "title",
     "format", "source", "usage", "param", "value", "description",
-    "details", "minidesc", "reexport", "field", "slot", "rcmethods", "note",
+    "details", "minidesc", "reexport", "field", "slot", "rcmethods", "note", "r6methods",
     "section", "examples", "author", "references", "seealso",
     "concept", "keyword", "rawRd")
 

R/rd-tag-api.R

@@ -222,8 +222,6 @@ describe_section <- function(name, dt, dd) {
   )
 }
 
-
-
 #' @export
 format.examples_tag <- function(x, ...) {
   values <- paste0(x$values, collapse = "\n")
@@ -235,6 +233,11 @@ format.rcmethods_tag <- function(x, ...) {
   describe_section("Methods", names(x$values), x$values)
 }
 
+#' @export
+format.r6methods_tag <- function(x, ...) {
+  describe_section("Methods", names(x$values), x$values)
+}
+
 #' @export
 format.minidesc_tag <- function(x, ...) {
   title <- switch(x$values$type,

R/roclet-rd.R

@@ -190,22 +190,61 @@ clean.rd_roclet <- function(roclet, base_path) {
 
 process_methods <- function(block) {
   obj <- block$object
-  if (!inherits(obj, "rcclass")) return()
-
-  methods <- obj$methods
-  if (is.null(obj$methods)) return()
-
-  desc <- lapply(methods, function(x) docstring([email protected]))
-  usage <- vapply(methods, function(x) {
-    usage <- function_usage(x$value@name, formals([email protected]))
-    as.character(wrap_string(usage))
-  }, character(1))
-
-  has_docs <- !vapply(desc, is.null, logical(1))
-  desc <- desc[has_docs]
-  usage <- usage[has_docs]
-
-  new_tag("rcmethods", setNames(desc, usage))
+  if (!inherits(obj, "rcclass") && !inherits(obj, "r6class")) return()
+
+
+  if(inherits(obj, "rcclass")) {
+      methods <- obj$methods
+      if (is.null(obj$methods)) return()
+
+      desc <- lapply(methods, function(x) docstring([email protected]))
+      usage <- vapply(methods, function(x) {
+          usage <- function_usage(x$value@name, formals([email protected]))
+          as.character(wrap_string(usage))
+      }, character(1))
+
+      has_docs <- !vapply(desc, is.null, logical(1))
+      desc <- desc[has_docs]
+      usage <- usage[has_docs]
+
+      return(new_tag("rcmethods", setNames(desc, usage)))
+  }
+  else if(inherits(obj, "r6class")) {
+      methods <- obj$methods
+      if (is.null(obj$methods)) return()
+
+      desc <- lapply(methods, function(x) docblock(x$value))
+      usage <- vapply(methods, function(x) {
+          usage <- function_usage(attr(x$value, "r6method"), formals(x$value))
+          as.character(wrap_string(usage))
+      }, character(1))
+
+      is_active <- vapply(methods, function(x) {attr(x$value, "r6is_active")}, logical(1))
+
+      has_docs <- !vapply(desc, is.null, logical(1))
+      ## if any doesn't have documentation, add a note to that effect into the documentation
+      if(any(!has_docs)) {
+              desc[!has_docs] <- "NO DOCUMENTATION AVAILABLE"
+      }
+
+      ## want to change it a little: The item name will just be the name of the function
+      ## then we insert a custom usage block
+      ## the consist of preformatted text
+      ## and then the description
+      usage_method_names <- vapply(methods, function(x) {attr(x$value, "r6method")}, character(1))
+      desc <- paste0("\n\n\\strong{Usage:}\n\\preformatted{", usage, "}\n", desc)
+      ## for active methods, add a NOTE at the beginning
+      if(any(is_active)) {
+          desc[is_active] <- paste0("Active method", desc[is_active])
+      }
+
+      usage <- usage_method_names
+
+      return(new_tag("r6methods", setNames(desc, usage)))
+  }
+  else {
+      stop("should not have reached this")
+  }
 }
 
 

R/topic-name.R

@@ -16,11 +16,23 @@ default_topic_name.rcclass <- function(x) {
   paste0(x$value@className, "-class")
 }
 
+
+#' @export
+default_topic_name.r6class <- function(x) {
+  paste0(x$value$classname, "-class")
+}
+
 #' @export
 default_topic_name.rcmethod <- function(x) {
   x@name
 }
 
+#' @export
+default_topic_name.r6method <- function(x) {
+  attr(x, "r6method")
+}
+
+
 #' @export
 default_topic_name.default <- function(x) {
   if (length(x$alias) == 1) return(x$alias)

R/usage.R

@@ -76,6 +76,9 @@ default_usage.s4class <- function(x) NULL
 #' @export
 default_usage.rcclass <- function(x) NULL
 
+#' @export
+default_usage.r6class <- function(x) NULL
+
 
 # Usage:
 # replacement, infix, regular