Various enhancements to support reporting

DESCRIPTION

@@ -37,6 +37,7 @@ BugReports:
 Imports:
     cli,
     desc,
+    evaluate,
     options,
     S7,
     tools,
@@ -48,6 +49,7 @@ Imports:
 Suggests:
     covr,
     rcmdcheck,
+    htmltools,
     igraph,
     knitr,
     rmarkdown,
@@ -99,7 +101,9 @@ Collate:
     'generic_metric_coerce.R'
     'options.R'
     'package.R'
+    'share-register-s3.R'
     'utils_backports.R'
+    'utils_evaluate.R'
     'utils_rand.R'
     'utils_rstudio.R'
     'utils_tmp.R'

NAMESPACE

@@ -5,18 +5,21 @@ S3method(".DollarNames","val.meter::pkg")
 S3method("[","val.meter::pkg")
 S3method("[[","val.meter::pkg")
 S3method(as.data.frame,list_of_pkg)
+S3method(format,evaluate_evaluation)
 S3method(format,val_meter_error)
 S3method(print,val_meter_error)
 export(class_metric_data_frame)
 export(class_package_matrix)
 export(cran_repo_resource)
 export(error)
+export(format_output)
 export(from_dcf)
 export(git_resource)
 export(impl_data)
 export(impl_data_derive)
 export(impl_data_info)
 export(install_resource)
+export(knit_print.evaluate_evaluation)
 export(local_resource)
 export(local_source_resource)
 export(metric_coerce)
@@ -36,6 +39,7 @@ export(random_repo)
 export(remote_resource)
 export(repo_resource)
 export(resource)
+export(s3_register)
 export(source_archive_resource)
 export(source_code_resource)
 export(tags)
@@ -44,6 +48,7 @@ import(S7)
 import(cli)
 import(options)
 importFrom(desc,desc)
+importFrom(evaluate,replay)
 importFrom(httr2,req_perform)
 importFrom(httr2,request)
 importFrom(httr2,resp_body_html)
@@ -57,6 +62,7 @@ importFrom(tools,getVignetteInfo)
 importFrom(tools,toRd)
 importFrom(utils,.DollarNames)
 importFrom(utils,available.packages)
+importFrom(utils,capture.output)
 importFrom(utils,download.packages)
 importFrom(utils,getCRANmirrors)
 importFrom(utils,head)

R/class_pkg.R

@@ -16,6 +16,11 @@ pkg <- class_pkg <- new_class(
     # necessary data dependencies to be evaluated.
     data = class_environment,
 
+    # logs (not user-facing)
+    # A mutable environment, stores output logs captured using the `evaluate`
+    # package. Should contain an entry for each value in `@data`.
+    logs = class_environment,
+
     #' @param resource [`resource`] (often a [`multi_resource`]), providing the
     #'   resources to be used for deriving packages data. If a
     #'   [`multi_resource`], the order of resources determines the precedence of
@@ -62,13 +67,25 @@ pkg <- class_pkg <- new_class(
     new_object(
       .parent = S7::S7_object(),
       data = new.env(parent = emptyenv()),
+      logs = new.env(parent = emptyenv()),
       metrics = list(),
       resource = resource,
       permissions = policy@permissions
     )
   }
 )
 
+method(convert, list(class_character, class_pkg)) <-
+  function(from, to, ...) {
+    if (endsWith(tolower(from), ".rds")) {
+      convert(readRDS(from), class_pkg)
+    } else if (grepl("\\bPackage:", from[[1L]])) {
+      pkg_from_dcf(from, ...)
+    } else {
+      pkg(from, ...)
+    }
+  }
+
 #' Generate Random Package(s)
 #'
 #' Create a package object to simulate metric derivation. When generating a
@@ -179,6 +196,8 @@ random_repo <- function(..., path = tempfile("repo")) {
 #' @param x [`pkg`] object to derive data for
 #' @param name `character(1L)` field name for the data to derive
 #' @param ... Additional arguments unused
+#' @param logs `logical(1L)` flag indicating whether console output should be
+#'   captured during execution.
 #' @param .raise `logical(1L)` flag indicating whether errors should be raised
 #'   or captured. This flag is not intended to be set directly, it is exposed
 #'   so that recursive calls can raise lower-level errors while capturing them
@@ -189,7 +208,13 @@ random_repo <- function(..., path = tempfile("repo")) {
 #'
 #' @keywords internal
 #' @include utils_err.R
-get_pkg_data <- function(x, name, ..., .raise = .state$raise) {
+get_pkg_data <- function(
+  x,
+  name,
+  ...,
+  logs = opt("logs"),
+  .raise = .state$raise
+) {
   # RStudio, when trying to produce completions,will try to evaluate our lazy
   # list elements. Intercept those calls and return only the existing values.
   if (is_rs_rpc_get_completions_call()) {
@@ -213,7 +238,19 @@ get_pkg_data <- function(x, name, ..., .raise = .state$raise) {
         assert_permissions(required_permissions, x@permissions)
         assert_suggests(required_suggests)
 
-        data <- pkg_data_derive(pkg = x, field = name, ...)
+        if (logs) {
+          capture <- capture_pkg_data_derive(pkg = x, field = name, ...)
+          data <- capture$data
+          x@logs[[name]] <- capture$logs
+
+          # re-throw error after storing logs if one was produced
+          if (inherits(data, "error")) {
+            stop(data)
+          }
+        } else {
+          data <- pkg_data_derive(pkg = x, field = name, ...)
+        }
+
         if (!identical(info@data_class, class_any)) {
           data <- convert(data, info@data_class)
         }
@@ -382,31 +419,59 @@ as.data.frame.list_of_pkg <- function(x, ...) {
 }
 
 #' @include utils_dcf.R
-method(from_dcf, list(class_character, class_pkg)) <-
-  function(x, to, ...) {
-    dcf <- from_dcf(x, class_any)
+method(convert, list(class_list, class_pkg)) <-
+  function(from, to, ...) {
     resource <- unknown_resource(
-      package = dcf[[1, "Package"]],
-      version = dcf[[1, "Version"]],
-      md5 = if ("MD5sum" %in% colnames(dcf)) {
-        dcf[[1, "MD5sum"]]
-      } else {
-        NA_character_
-      }
+      package = from$name %||% from$Package,
+      version = from$version %||% from$Version,
+      md5 = from$MD5sum %||% NA_character_
     )
 
     data <- new.env(parent = emptyenv())
+    for (name in names(from)) {
+      # recover gracefully from unknown fieldnames
+      info <- tryCatch(pkg_data_info(name), error = function(e) NULL)
+      if (is.null(info)) {
+        next
+      }
+
+      data[[name]] <- metric_coerce(from[[name]], info@data_class)
+    }
+
+    pkg <- pkg(resource)
+    pkg@data <- data
+
+    pkg
+  }
+
+#' @include utils_dcf.R
+method(from_dcf, list(class_character, class_pkg)) <-
+  function(x, to, ...) {
+    dcf <- from_dcf(x, class_any)
+
+    data <- list()
+    data$name <- dcf[[1, "Package"]]
+    data$version <- dcf[[1, "Version"]]
+    data$md5 <- if ("MD5sum" %in% colnames(dcf)) {
+      dcf[[1, "MD5sum"]]
+    } else {
+      NA_character_
+    }
+
     prefix <- "Metric/"
     for (name in colnames(dcf)[startsWith(colnames(dcf), prefix)]) {
       field <- sub(prefix, "", name)
-      info <- pkg_data_info(field)
+
+      # recover gracefully from unknown fieldnames
+      info <- tryCatch(pkg_data_info(field), error = function(e) NULL)
+      if (is.null(info)) {
+        next
+      }
+
       val <- dcf[[1, name]]
       val <- metric_coerce(val, info@data_class)
       data[[field]] <- val
     }
 
-    pkg <- pkg(resource)
-    pkg@data <- data
-
-    pkg
+    convert(data, class_pkg)
   }

R/class_resource.R

@@ -284,9 +284,11 @@ method(convert, list(class_character, class_resource)) <-
     add_resource <- function(resource) {
       resource_type_name <- class_desc(S7::S7_class(resource))
       idx <- match(resource_type_name, all_resource_type_names)
+
       if (is.na(idx) || !is.null(resources[[idx]])) {
         return()
       }
+
       resources[[idx]] <<- resource
       idx
     }
@@ -317,8 +319,8 @@ method(convert, list(class_character, class_resource)) <-
       # iterate over other allowed resource types
       for (to_idx in seq_along(all_resource_types)) {
         # that are not yet populated with a known resource
-        to_resource <- resources[[to_idx]]
-        if (!is.null(to_resource)) {
+        existing_resource <- resources[[to_idx]]
+        if (!is.null(existing_resource)) {
           next
         }
 
@@ -336,7 +338,7 @@ method(convert, list(class_character, class_resource)) <-
         # special handling for error conditions used to test discovery in tests
         if (inherits(result, "test_suite_signal")) {
           stop(result)
-        } else if (inherits(result, "error")) {
+        } else if (is.null(result) || inherits(result, "error")) {
           next
         }
 
@@ -589,7 +591,9 @@ method(convert, list(class_local_source_resource, class_install_resource)) <-
 
 method(convert, list(class_resource, class_unknown_resource)) <-
   function(from, to, ...) {
-    set_props(to(), props(from, names(class_unknown_resource@properties)))
+    out <- to()
+    props(out) <- props(from, prop_names(out))
+    out
   }
 
 method(to_dcf, class_resource) <- function(x, ...) {

R/data_coverage.R

@@ -9,8 +9,10 @@ impl_data(
 impl_data(
   "covr_coverage",
   for_resource = local_source_resource,
-  function(pkg, resource, field, ..., quiet = opt("quiet")) {
-    covr::package_coverage(resource@path, type = "tests", quiet = quiet)
+  function(pkg, resource, field, ...) {
+    # package installs use `system2()` whose output cannot be captured by sink()
+    # so we just execute quietly
+    covr::package_coverage(resource@path, type = "tests", quiet = TRUE)
   }
 )
 
@@ -23,7 +25,7 @@ impl_data(
     "The fraction of expressions of package code that are evaluated by any ",
     "test"
   ),
-  function(pkg, resource, field, ..., quiet = opt("quiet")) {
+  function(pkg, resource, field, ...) {
     tally <- covr::tally_coverage(pkg$covr_coverage, by = "expression")
     mean(tally$value > 0)
   }
@@ -45,7 +47,7 @@ impl_data(
   description = paste0(
     "The fraction of lines of package code that are evaluated by any test"
   ),
-  function(pkg, resource, field, ..., quiet = opt("quiet")) {
+  function(pkg, resource, field, ...) {
     tally <- covr::tally_coverage(pkg$covr_coverage, by = "line")
     mean(tally$value > 0)
   }

R/data_desc.R

@@ -14,14 +14,15 @@ impl_data(
   "name",
   title = "Package name",
   class = class_character,
+  for_resource = new_union(source_code_resource, install_resource),
   function(pkg, resource, field, ...) {
     pkg$desc$get_field("Package")
   }
 )
 
 impl_data(
   "name",
-  for_resource = repo_resource,
+  for_resource = class_resource,
   function(pkg, resource, field, ...) {
     resource@package
   }
@@ -30,19 +31,37 @@ impl_data(
 impl_data(
   "version",
   class = class_character,
+  for_resource = new_union(source_code_resource, install_resource),
   function(pkg, resource, field, ...) {
     pkg$desc$get_field("Version")
   }
 )
 
 impl_data(
   "version",
-  for_resource = repo_resource,
+  for_resource = class_resource,
   function(pkg, resource, field, ...) {
     resource@version
   }
 )
 
+impl_data(
+  "md5",
+  class = class_character,
+  for_resource = new_union(source_code_resource, install_resource),
+  function(pkg, resource, field, ...) {
+    pkg$desc$get_field("MD5sum")
+  }
+)
+
+impl_data(
+  "md5",
+  for_resource = class_resource,
+  function(pkg, resource, field, ...) {
+    resource@md5
+  }
+)
+
 impl_data(
   "dependency_count",
   class = class_integer,

R/data_r_cmd_check.R

@@ -14,26 +14,12 @@ impl_data(
     local_source_resource,
     source_archive_resource
   ),
-  function(pkg, resource, field, ..., quiet = opt("quiet")) {
-    # suppress messages to avoid stdout output from subprocess
-    # (eg warnings about latex availability not suppressed by rcmdcheck)
-
-    wrapper <- if (quiet) {
-      function(...) capture.output(..., type = "message")
-    } else {
-      identity
-    }
-
-    wrapper({
-      result <- rcmdcheck::rcmdcheck(
-        resource@path,
-        quiet = quiet,
-        error_on = "never",
-        build_args = "--no-manual"
-      )
-    })
-
-    result
+  function(pkg, resource, field, ...) {
+    rcmdcheck::rcmdcheck(
+      resource@path,
+      error_on = "never",
+      build_args = "--no-manual"
+    )
   }
 )