Dev/cohort assess

DESCRIPTION

@@ -35,13 +35,15 @@ Imports:
     pillar,
     tibble,
     pkgload,
-    devtools
+    devtools,
+    igraph,
+    dplyr,
+    stringr
 Suggests:
     knitr,
     rmarkdown,
     withr,
     magrittr,
-    dplyr,
     testthat,
     webmockr,
     jsonlite

NAMESPACE

@@ -7,11 +7,14 @@ S3method("[<-",pkg_ref)
 S3method("[[",pkg_ref)
 S3method("[[<-",pkg_ref)
 S3method(.DollarNames,pkg_ref)
+S3method(as_cohort_metric,default)
+S3method(as_cohort_metric,expr_output)
 S3method(as_pkg_metric,default)
 S3method(as_pkg_metric,expr_output)
 S3method(as_pkg_ref,character)
 S3method(as_pkg_ref,default)
 S3method(as_pkg_ref,pkg_ref)
+S3method(as_tibble,cohort_ref)
 S3method(as_tibble,list_of_pkg_ref)
 S3method(as_tibble,pkg_ref)
 S3method(assess_covr_coverage,default)
@@ -25,9 +28,12 @@ S3method(assess_downloads_1yr,pkg_ref)
 S3method(assess_export_help,pkg_install)
 S3method(assess_export_help,pkg_remote)
 S3method(assess_export_help,pkg_source)
+S3method(assess_exported_namespace,cohort_ref)
 S3method(assess_exported_namespace,default)
 S3method(assess_exported_namespace,pkg_install)
 S3method(assess_exported_namespace,pkg_source)
+S3method(assess_has_bug_reports_url,pkg_ref)
+S3method(assess_has_dependency_conflict,cohort_ref)
 S3method(assess_has_news,pkg_ref)
 S3method(assess_has_vignettes,pkg_ref)
 S3method(assess_news_current,pkg_ref)
@@ -39,11 +45,19 @@ S3method(assess_r_cmd_check,pkg_source)
 S3method(assess_remote_checks,default)
 S3method(assess_remote_checks,pkg_bioc_remote)
 S3method(assess_remote_checks,pkg_cran_remote)
+S3method(assess_reverse_dependencies,cohort_ref)
 S3method(assess_reverse_dependencies,default)
+S3method(cohort_assess,cohort_ref)
+S3method(cohort_score,list_of_cohort_metric)
+S3method(format,cohort_metric)
+S3method(format,cohort_metric_error)
 S3method(format,pkg_metric)
 S3method(format,pkg_metric_error)
 S3method(format,pkg_missing)
 S3method(format,pkg_ref)
+S3method(metric_score,cohort_metric_dependency_conflict)
+S3method(metric_score,cohort_metric_exported_namespace)
+S3method(metric_score,cohort_metric_reverse_dependencies)
 S3method(metric_score,default)
 S3method(metric_score,pkg_metric_covr_coverage)
 S3method(metric_score,pkg_metric_dependencies)
@@ -71,6 +85,7 @@ S3method(pkg_assess,pkg_ref)
 S3method(pkg_assess,tbl_df)
 S3method(pkg_score,list_of_pkg_metric)
 S3method(pkg_score,tbl_df)
+S3method(print,cohort_ref)
 S3method(print,pkg_ref)
 S3method(print,with_eval_recording)
 S3method(summarize_scores,data.frame)
@@ -81,6 +96,9 @@ S3method(vec_ptype_abbr,pkg_metric)
 S3method(vec_ptype_abbr,pkg_ref)
 S3method(with,pkg_ref)
 export(all_assessments)
+export(all_cohort_assessments)
+export(as_cohort_metric)
+export(as_list_of_pkg_ref)
 export(as_pkg_metric)
 export(as_pkg_ref)
 export(assess_covr_coverage)
@@ -89,6 +107,7 @@ export(assess_downloads_1yr)
 export(assess_export_help)
 export(assess_exported_namespace)
 export(assess_has_bug_reports_url)
+export(assess_has_dependency_conflict)
 export(assess_has_maintainer)
 export(assess_has_news)
 export(assess_has_source_control)
@@ -103,8 +122,13 @@ export(assess_reverse_dependencies)
 export(assessment_error_as_warning)
 export(assessment_error_empty)
 export(assessment_error_throw)
+export(cohort_assess)
+export(cohort_metric)
+export(cohort_ref)
+export(cohort_score)
 export(get_assessments)
 export(metric_score)
+export(new_list_of_pkg_ref)
 export(pkg_assess)
 export(pkg_metric)
 export(pkg_ref)
@@ -124,13 +148,16 @@ importFrom(cranlogs,cran_downloads)
 importFrom(curl,nslookup)
 importFrom(devtools,check)
 importFrom(devtools,revdep)
+importFrom(dplyr,bind_rows)
 importFrom(httr,GET)
 importFrom(httr,content)
+importFrom(igraph,fit_power_law)
 importFrom(memoise,memoise)
 importFrom(pillar,new_pillar_shaft_simple)
 importFrom(pillar,pillar_shaft)
 importFrom(pillar,style_na)
 importFrom(pkgload,parse_ns_file)
+importFrom(stringr,str_extract)
 importFrom(tibble,as_tibble)
 importFrom(tibble,tibble)
 importFrom(tools,Rd_db)
@@ -143,8 +170,10 @@ importFrom(utils,.DollarNames)
 importFrom(utils,.S3methods)
 importFrom(utils,available.packages)
 importFrom(utils,capture.output)
+importFrom(utils,compareVersion)
 importFrom(utils,getS3method)
 importFrom(utils,head)
+importFrom(utils,installed.packages)
 importFrom(utils,packageDescription)
 importFrom(utils,packageName)
 importFrom(utils,packageVersion)

R/assess_dependencies.R

@@ -26,45 +26,31 @@ assess_dependencies.default <- function(x, ...){
 #' @export
 assess_dependencies.pkg_source <- function(x, ...){
   pkg_metric_eval(class = "pkg_metric_dependencies", {
-    parse_dcf_dependencies(x$path)
+    NROW(x$dependencies)
     })
 }
 
 #' @export
 assess_dependencies.pkg_install <- function(x, ...){
   pkg_metric_eval(class = "pkg_metric_dependencies", {
-    parse_dcf_dependencies(x$path)
+    NROW(x$dependencies)
   })
 }
 
 #' @export
 assess_dependencies.pkg_cran_remote <- function(x, ...){
-  #Attempt to find CRAN URL by matching all urls returned by getOptions("repos") to memoise_cran_mirrors table
-  repos <- getOption("repos")[which(getOption("repos") %in% memoise_cran_mirrors()$URL)]
-
-  if(length(repos)==0){
-    repos <- grep("[\\.|//]cran\\.", getOption("repos"), ignore.case = T, value = T)
-  }
-  if(length(repos)==0){
-    repos <- getOption("repos")[["CRAN"]]
-  }
-
-  if(length(repos)==0){
-    as_pkg_metric_error(error = 'Could not determine which CRAN mirror you are using.')
-  } else{
     pkg_metric_eval(class = "pkg_metric_dependencies", {
-        get_package_dependencies(x$name, repo = repos[1]) ##Will use the first CRAN mirror found in the users environment
+        NROW(x$dependencies)
     })
-  }
 }
 
 #' @importFrom BiocManager repositories
 #' @export
 assess_dependencies.pkg_bioc_remote <- function(x, ...){
-  pkg_metric_eval(class = "pkg_metric_dependencies", {
-    get_package_dependencies(x$name, BiocManager::repositories()[1])
-  })
-}
+    pkg_metric_eval(class = "pkg_metric_dependencies", {
+      NROW(x$dependencies)
+    })
+  }
 
 #' Score a package for dependencies
 #'
@@ -84,7 +70,7 @@ assess_dependencies.pkg_bioc_remote <- function(x, ...){
 #'
 #' @export
 metric_score.pkg_metric_dependencies <- function(x, ...) {
-  1 - 1/(1 + exp(-0.5 * (NROW(x) - 4)))
+  1 - 1/(1 + exp(-0.5 * (x - 4)))
 }
 attributes(metric_score.pkg_metric_dependencies)$label <-
   "The number of package dependencies"
@@ -138,7 +124,6 @@ remove_base_packages <- function(df){
   inst_priority <- inst[,"Priority"]
   inst_is_base_rec <- !is.na(inst_priority) & inst_priority %in% c("base", "recommended")
   base_rec_pkgs <- inst[inst_is_base_rec, "Package"]
-
   deps <- df[!grepl("^R\\s\\(.+\\)", df$package) | df$package %in% base_rec_pkgs, ] ##Remove "R" dependencies as well as base and recomended
   return(deps)
 }

R/assess_exported_namespace.R

@@ -1,4 +1,4 @@
-#' Assess a package's results from running R CMD check
+#' Assess a package's exported namespace
 #'
 #' @eval roxygen_assess_family(
 #'   "exported_namespace",
@@ -17,7 +17,7 @@ attributes(assess_exported_namespace)$label <- "Objects exported by package"
 #' @export
 assess_exported_namespace.default <- function(x, ...) {
   as_pkg_metric_na(
-    pkg_metric(class = "pkg_metric_export_help"),
+    pkg_metric(class = "pkg_metric_exported_namespace"),
     message = sprintf("Cannot export namespace from a %s", x$source))
 }
 
@@ -37,6 +37,15 @@ assess_exported_namespace.pkg_source <- function(x, ...) {
   })
 }
 
+#' @export
+assess_exported_namespace.cohort_ref <- function(x, ...) {
+  ns <- unlist(lapply(x$cohort, assess_exported_namespace))
+  return(cohort_metric_eval(class = "cohort_metric_exported_namespace",
+                            ns
+  ))
+}
+
+
 #' Score a package for the number of exported objects
 #'
 #' Score a package for the number of exported objects it has; regularized
@@ -61,3 +70,29 @@ metric_score.pkg_metric_exported_namespace <- function(x, ...) {
 
 attributes(metric_score.pkg_metric_exported_namespace)$label <-
   "The number of exported objects in a package"
+
+
+#' Score a cohort for the number of exported objects
+#'
+#' Score a cohort for the number of exported objects it has; regularized
+#' Convert the number of exported objects \code{length(x)} into a validation
+#' score [0,1] \deqn{ 1 / (1 + exp(-0.5 * (sqrt(length(x)) + sqrt(5)))) }
+#'
+#' The scoring function is the classic logistic curve \deqn{
+#' 1 / (1 + exp(-k(x-x[0])) } with a square root scale for the number of exported objects
+#' \eqn{x = sqrt(length(x))}, sigmoid midpoint is 25 exported objects, ie. \eqn{x[0] =
+#' sqrt(5)}, and logistic growth rate of \eqn{k = 0.25}.
+#'
+#' \deqn{ 1 / (1 + exp(-0.25 * sqrt(length(x))-sqrt(25))) }
+#'
+#' @eval roxygen_score_family("exported_namespace")
+#' @return numeric value between \code{0} (high number of exported objects) and
+#'   \code{1} (low number of exported objects)
+#'
+#' @export
+metric_score.cohort_metric_exported_namespace <- function(x, ...) {
+  1 - 1 / (1 + exp(-0.25 * (sqrt(length(x)) - sqrt(25))))
+}
+
+attributes(metric_score.cohort_metric_exported_namespace)$label <-
+  "The number of exported objects in a cohort"

R/assess_has_bug_reports_url.R

@@ -6,9 +6,7 @@
 #'
 #' @export
 assess_has_bug_reports_url <- function(x, ...) {
-  pkg_metric_eval(class = "pkg_metric_has_bug_reports_url", {
-    as.character(x$bug_reports_url)
-  })
+  UseMethod("assess_has_bug_reports_url")
 }
 
 # assign a friendly name for assess column
@@ -20,7 +18,7 @@ attr(assess_has_bug_reports_url,"label") <- "presence of a bug reports url in re
 #' @export
 assess_has_bug_reports_url.pkg_ref <- function(x, ...) {
   pkg_metric(class = "pkg_metric_has_bug_reports_url", {
-    length(x$bug_reports_url)
+    as.character(x$bug_reports_url)
   })
 }
 

R/assess_has_dependency_conflict.R

@@ -0,0 +1,67 @@
+#' Assess a cohort for the presence of dependency conflicts
+#'
+#' @param x cohort_ref
+#' @param ... currently ignored
+#' @export
+#'
+assess_has_dependency_conflict <- function(x, ...){
+  UseMethod("assess_has_dependency_conflict")
+}
+attributes(assess_has_dependency_conflict)$column_name <- "dependency_conflict"
+attributes(assess_has_dependency_conflict)$label <- "Cohort dependency conflicts"
+
+assess_has_dependency_conflict.pkg_ref <- function(x, ...){
+  as_pkg_metric_na(
+    pkg_metric(class = "pkg_metric_dependency_conflict"),
+    message = "Dependency conflicts not relevant for an individual package.")
+}
+attributes(assess_has_dependency_conflict)$column_name <- "dependency_conflict"
+attributes(assess_has_dependency_conflict)$label <- "Cohort dependency conflicts"
+
+#' @importFrom stringr str_extract
+#' @importFrom utils compareVersion
+#' @export
+assess_has_dependency_conflict.cohort_ref <- function(x, ...){
+  dep <- lapply(x$cohort, "[[", "dependencies")
+  nm <- unlist(lapply(x$cohort, "[", "name"))
+
+  nm_lib <- as_tibble(x$library)[, c(1:2)]
+
+  dep <- data.frame(ref=rep(nm, sapply(dep, nrow)), bind_rows(dep))
+  dep$version <- str_extract(dep$package, "(?<=\\().+(?=\\))")
+  dep$version<- str_extract(dep$version, "\\d+\\.\\d+(\\.\\d+)*")
+  dep$package <- trimws(gsub("\\(.+\\)", "", dep$package))
+  dep2 <- list(minVer = tapply(dep$version, dep$package, function(x) sort(x, decreasing = T)[1]),
+               minDep = tapply(dep$type, dep$package, function(x) sort(x)[1]))
+  dep2 <- merge(as.data.frame(dep2$minVer), as.data.frame(dep2$minDep), by="row.names")
+
+  lib <- rbind(nm_lib, data.frame(package=nm, version=unlist(lapply(x$cohort, "[", "version"))))
+  dep3 <- merge(dep2, lib, by.x="Row.names", by.y="package", all.x = TRUE)
+  dep3$conflict <- apply(dep3, 1, function(x) {
+    if(is.na(x[4])){
+      return(TRUE)
+    } else if(is.na(x[2]) & !is.na(x[4])){
+        return(FALSE)
+      } else if (compareVersion(x[2],x[4])>0){
+        return(TRUE)
+      } else {
+        return(FALSE)
+          }
+    })
+  colnames(dep3) <- c("Pkg_dependency", "MinimumVersion","Type", "CurrentVersion", "IsConflict")
+  cohort_metric_eval(class= "cohort_metric_dependency_conflict",
+                     dep3[dep3$IsConflict, ])
+}
+
+#' Score a package for presence of dependency conflicts
+#'
+#' @param x cohort assessment
+#' @param ... named list of arguments to adjust metric scoring. currently ignored.
+#' @return \code{1} if any dependencies are missing or conflicting, otherwise \code{0}
+#'
+#' @export
+metric_score.cohort_metric_dependency_conflict <- function(x, ...) {
+  as.numeric(NROW(x) > 0)
+}
+
+attributes(metric_score.cohort_metric_dependency_conflict)$label <- "Binary indicator of the presence of a dependency conflict"

R/assess_reverse_dependencies.R

@@ -20,8 +20,28 @@ assess_reverse_dependencies.default <- function(x, ...){
   )
 }
 
+#' @importFrom devtools revdep
+#' @export
+assess_reverse_dependencies.cohort_ref <- function(x, ...){
+  cohort_rev_deps <- lapply(x$cohort, assess_reverse_dependencies)
+  cohort_nm <- sapply(x$cohort, "[[", "name")
+
+  cohort_rev_deps <- data.frame(pkg=rep(cohort_nm, sapply(cohort_rev_deps, length)),
+                                revdep=unlist(cohort_rev_deps))
+
+  if(length(x$library)){
+    lib_pkgs <- sapply(x$library, function(x) x$name)
+  }
+
+  return(cohort_metric_eval(class = "cohort_metric_reverse_dependencies",
+                  cohort_rev_deps[cohort_rev_deps$revdep %in% c(lib_pkgs, cohort_nm), ]
+    )
+  )
+}
+
 attr(assess_reverse_dependencies, "column_name") <- "reverse_dependencies"
-attr(assess_reverse_dependencies, "label") <- "List of reverse dependencies a package has"
+attr(assess_reverse_dependencies, "label") <- "Table of reverse dependencies for each package."
+
 
 #' Scoring method for number of reverse dependencies a package has
 #'
@@ -48,3 +68,16 @@ metric_score.pkg_metric_reverse_dependencies <- function(x,...){
 attributes(metric_score.pkg_metric_reverse_dependencies)$label <-
   "The (log10) number of packages that depend on this package."
 
+
+#' Metric for the assessment of reverse dependencies of a cohort.
+#'
+#' @param x cohort assessment
+#' @param ... named list of arguments that are currently ignored
+#' @importFrom igraph fit_power_law
+#' @export
+metric_score.cohort_metric_reverse_dependencies <- function(x, ...){
+  igraph::fit_power_law(tapply(x$revdep, x$pkg, length))$KS.p
+}
+attributes(metric_score.cohort_metric_reverse_dependencies)$label <-
+  "p-value of power law distribution fit"
+