From b3a95dec0cb9bb886794d3e1610c0f3433ab2da4 Mon Sep 17 00:00:00 2001 From: bburns632 Date: Fri, 3 May 2024 11:58:48 -0500 Subject: [PATCH] Core Function Changes to Accommodate Empty Lists in Recursion, Covr Behavior on Windows & Vignette Path Warnings (#322) --- .github/workflows/release.yml | 2 +- NEWS.md | 3 + R/CreatePackageVignette.R | 36 --------- R/FunctionReporter.R | 72 ++++++++++------- R/testing_utils.R | 1 + inst/control/DESCRIPTION | 12 +++ inst/control/LICENSE | 1 + inst/control/NAMESPACE | 5 ++ inst/control/R/self_control.R | 23 ++++++ inst/control/R/self_control_R6.R | 29 +++++++ inst/control/man/next_up.Rd | 11 +++ inst/control/man/take_a_break.Rd | 11 +++ inst/control/man/testClass.Rd | 60 ++++++++++++++ .../package_vignette_template.Rmd | 2 +- .../test-0-test-package-installation.R | 2 +- tests/testthat/test-CreatePackageReport.R | 34 ++++++++ tests/testthat/test-CreatePackageVignette.R | 48 ----------- tests/testthat/test-FunctionReporter-class.R | 81 +++++++++++++++++++ 18 files changed, 319 insertions(+), 114 deletions(-) create mode 100644 inst/control/DESCRIPTION create mode 100644 inst/control/LICENSE create mode 100644 inst/control/NAMESPACE create mode 100644 inst/control/R/self_control.R create mode 100644 inst/control/R/self_control_R6.R create mode 100644 inst/control/man/next_up.Rd create mode 100644 inst/control/man/take_a_break.Rd create mode 100644 inst/control/man/testClass.Rd diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 0204e9a6..0ea1c62e 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -79,7 +79,7 @@ jobs: with: fetch-depth: 1 - name: If local, apt update - if: ${ (env.ACT || false)} + if: ${{ (env.ACT || false)}} run: sudo apt update - name: Install Tidy Ubuntu run: sudo apt install -y tidy diff --git a/NEWS.md b/NEWS.md index 80ff5794..5444ca60 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,8 +5,11 @@ ## CHANGES * Updated `pkgnet-intro` vignette to include information on the Class Inheritance Reporter and other minor edits. +* Recursive functions `.parse_function` and `.parse_R6_expression` made tolerant to control statemets like `break` or `next` that would break the recursion. (#322) +* Excessive warnings removed for custom `vignette_path` param in `CreatePackageVignette()` (#322) ## BUGFIXES +* `CreatePackageReporter()` failing on Windows to build package coverage when `report_path` specified. (#322) # pkgnet 0.4.2 ## NEW FEATURES diff --git a/R/CreatePackageVignette.R b/R/CreatePackageVignette.R index 8f423d6b..07c7edb8 100644 --- a/R/CreatePackageVignette.R +++ b/R/CreatePackageVignette.R @@ -85,42 +85,6 @@ CreatePackageVignette <- function(pkg = "." , dirname(vignette_path))) } - # Check if vignette_path matches the right package - # if the path is to a file in a directory named vignettes - vignetteDirAbsPath <- normalizePath(dirname(vignette_path)) - # If path is a vignettes directory - if (grepl('/vignettes$', vignetteDirAbsPath)) { - # Get path for expected DESCRIPTION file for package - expectedDescriptionPath <- gsub( - pattern = "vignettes$" - , replacement = "DESCRIPTION" - , x = vignetteDirAbsPath - ) - - # If DESCRIPTION file exists check the name - if (file.exists(expectedDescriptionPath)) { - foundPkgName <- read.dcf(expectedDescriptionPath)[1,][["Package"]] - - # If it doesn't match pkg_name, give warning - if (!identical(foundPkgName, pkg_name)) { - log_warn(glue::glue( - "You are writing a report for {pkg_name} to the vignettes " - , "directory for {foundPkgName}" - , pkg_name = pkg_name - , foundPkgName = foundPkgName)) - } - - # Otherwise, warn that we're writing to a vignettes folder inside - # a directory that is not a package root - } else { - log_warn(paste( - "You specified a path to a vignettes directory" - , vignetteDirAbsPath - , "that is not inside a package root directory." - )) - } - } - log_info(sprintf( "Creating pkgnet package report as vignette for %s..." , pkg_name diff --git a/R/FunctionReporter.R b/R/FunctionReporter.R index d8ca0c3e..33036465 100644 --- a/R/FunctionReporter.R +++ b/R/FunctionReporter.R @@ -151,12 +151,22 @@ FunctionReporter <- R6::R6Class( log_info(sprintf("Calculating test coverage for %s...", self$pkg_name)) + # workaround for covr conflict with loaded packages on windows + if(.Platform$OS.type == "windows") { + detach(paste0('package:',self$pkg_name), unload = TRUE, character.only = TRUE) + } + pkgCovDT <- data.table::as.data.table(covr::package_coverage( path = private$pkg_path , type = "tests" , combine_types = FALSE )) + # workaround for covr conflict with loaded packages on windows + if(.Platform$OS.type == "windows") { + attachNamespace(self$pkg_name) + } + pkgCovDT <- pkgCovDT[, .(coveredLines = sum(value > 0) , totalLines = .N , coverageRatio = sum(value > 0)/.N @@ -395,12 +405,17 @@ FunctionReporter <- R6::R6Class( if (!is.list(x) && listable) { x <- as.list(x) - # Check for expression of the form foo$bar - # We still want to split it up because foo might be a function - # but we want to get rid of bar, because it's a symbol in foo's namespace - # and not a symbol that could be reliably matched to the package namespace - if (identical(x[[1]], quote(`$`))) { - x <- x[1:2] + if (length(x) > 0){ + # Check for expression of the form foo$bar + # We still want to split it up because foo might be a function + # but we want to get rid of bar, because it's a symbol in foo's namespace + # and not a symbol that could be reliably matched to the package namespace + if (identical(x[[1]], quote(`$`))) { + x <- x[1:2] + } + } else { + # make empty lists "not listable" so recursion stops + listable <- FALSE } } @@ -640,35 +655,38 @@ FunctionReporter <- R6::R6Class( # an environment pointer then we can break x up into list of components listable <- (!is.atomic(x) && !is.symbol(x) && !is.environment(x)) + # If it is not a list but listable... if (!is.list(x) && listable) { + # Convert to list xList <- as.list(x) - - # Check if expression x is from _$_ - if (identical(xList[[1]], quote(`$`))) { - - # Check if expression x is of form self$foo, private$foo, or super$foo - # We want to keep those together because they could refer to the class' - # methods. So expression is not listable - if (identical(xList[[2]], quote(self)) - || identical(xList[[2]], quote(private)) - || identical(xList[[2]], quote(super))) { - listable <- FALSE - - # If expression lefthand side is not keyword, we still want to split - # it up because left might be a function - # but we want to get rid of right, because it's a symbol in left's namespace - # and not a symbol that could be reliably matched to the package namespace + if (length(xList) > 0){ + # Check if expression x is from _$_ + if (identical(xList[[1]], quote(`$`))) { + # Check if expression x is of form self$foo, private$foo, or super$foo + if (identical(xList[[2]], quote(self)) || identical(xList[[2]], quote(private)) || identical(xList[[2]], quote(super))) { + # We want to keep those together because they could refer to the class' + # methods. So expression is not listable + listable <- FALSE + } else { + # If expression lefthand side is not keyword, we still want to split + # it up because left might be a function + # but we want to get rid of right, because it's a symbol in left's namespace + # and not a symbol that could be reliably matched to the package namespace + x <- xList[1:2] + } } else { + # Left Hand is not a _$_. Proceed as normal list. x <- xList - x <- x[1:2] } - - # Otherwise list as usual } else { - x <- xList - } + # List is zero length. This might occur when encountering a "break" command. + # Make empty list "non-listable" so recursion stops in following step. + listable <- FALSE + } } + + if (listable){ # Filter out atomic values because we don't care about them x <- Filter(f = Negate(is.atomic), x = x) diff --git a/R/testing_utils.R b/R/testing_utils.R index 3ce1af65..1f940d91 100644 --- a/R/testing_utils.R +++ b/R/testing_utils.R @@ -65,6 +65,7 @@ , sartre = file.path(pkgnetSourcePath, testPkgSourceDir, "sartre") , milne = file.path(pkgnetSourcePath, testPkgSourceDir, "milne") , silverstein = file.path(pkgnetSourcePath, testPkgSourceDir, "silverstein") + , control = file.path(pkgnetSourcePath, testPkgSourceDir, "control") , pkgnet = pkgnetSourcePath ) diff --git a/inst/control/DESCRIPTION b/inst/control/DESCRIPTION new file mode 100644 index 00000000..25eeb5f3 --- /dev/null +++ b/inst/control/DESCRIPTION @@ -0,0 +1,12 @@ +Package: control +Type: Package +Title: Have self control, don't break! +Version: 0.1 +Author: Brian Burns +Maintainer: Brian Burns +Description: This package is used to test that functions in pkgnet don't break on control statements. +Imports: + R6 +License: file LICENSE +LazyData: TRUE +RoxygenNote: 7.3.1 diff --git a/inst/control/LICENSE b/inst/control/LICENSE new file mode 100644 index 00000000..d73603e3 --- /dev/null +++ b/inst/control/LICENSE @@ -0,0 +1 @@ +this is a test package diff --git a/inst/control/NAMESPACE b/inst/control/NAMESPACE new file mode 100644 index 00000000..0ad4b1da --- /dev/null +++ b/inst/control/NAMESPACE @@ -0,0 +1,5 @@ +# Generated by roxygen2: do not edit by hand + +export(next_up) +export(take_a_break) +export(testClass) diff --git a/inst/control/R/self_control.R b/inst/control/R/self_control.R new file mode 100644 index 00000000..594b6bf7 --- /dev/null +++ b/inst/control/R/self_control.R @@ -0,0 +1,23 @@ +#' @title Take a Break +#' @name take_a_break +#' @description Test if .parse_function() breaks with control function 'break' +#' @export +take_a_break <- function() { + for (i in 1:10){ + if (i==5){ + break + } + } + } + +#' @title Next Up +#' @name next_up +#' @description Test if .parse_function() breaks with control function 'next' +#' @export +next_up <- function() { + for (i in 1:10){ + if (i==5){ + next + } + } + } \ No newline at end of file diff --git a/inst/control/R/self_control_R6.R b/inst/control/R/self_control_R6.R new file mode 100644 index 00000000..ba7690a2 --- /dev/null +++ b/inst/control/R/self_control_R6.R @@ -0,0 +1,29 @@ +#' Test Class for Control Statements +#' +#' @description A Test Class for Control Statements handling in R6 +#' @export +testClass <- R6::R6Class( + classname = "testClass", + public = list( + #' @description + #' Test if .parse_R6_expression () breaks with control function 'break' + #' @return Nothing + take_a_break = function() { + for (i in 1:10){ + if (i==5){ + break + } + } + }, + #' @description + #' Test if .parse_R6_expression () breaks with control function 'next' + #' @return Nothing + next_up = function() { + for (i in 1:10){ + if (i==5){ + next + } + } + } + ) +) diff --git a/inst/control/man/next_up.Rd b/inst/control/man/next_up.Rd new file mode 100644 index 00000000..939575c4 --- /dev/null +++ b/inst/control/man/next_up.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/self_control.R +\name{next_up} +\alias{next_up} +\title{Next Up} +\usage{ +next_up() +} +\description{ +Test if .parse_function() breaks with control function 'next' +} diff --git a/inst/control/man/take_a_break.Rd b/inst/control/man/take_a_break.Rd new file mode 100644 index 00000000..28f41544 --- /dev/null +++ b/inst/control/man/take_a_break.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/self_control.R +\name{take_a_break} +\alias{take_a_break} +\title{Take a Break} +\usage{ +take_a_break() +} +\description{ +Test if .parse_function() breaks with control function 'break' +} diff --git a/inst/control/man/testClass.Rd b/inst/control/man/testClass.Rd new file mode 100644 index 00000000..d6ed69cc --- /dev/null +++ b/inst/control/man/testClass.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/self_control_R6.R +\name{testClass} +\alias{testClass} +\title{Test Class for Control Statements} +\description{ +A Test Class for Control Statements handling in R6 +} +\section{Methods}{ +\subsection{Public methods}{ +\itemize{ +\item \href{#method-testClass-take_a_break}{\code{testClass$take_a_break()}} +\item \href{#method-testClass-next_up}{\code{testClass$next_up()}} +\item \href{#method-testClass-clone}{\code{testClass$clone()}} +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-testClass-take_a_break}{}}} +\subsection{Method \code{take_a_break()}}{ +Test if .parse_R6_expression () breaks with control function 'break' +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{testClass$take_a_break()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +Nothing +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-testClass-next_up}{}}} +\subsection{Method \code{next_up()}}{ +Test if .parse_R6_expression () breaks with control function 'next' +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{testClass$next_up()}\if{html}{\out{
}} +} + +\subsection{Returns}{ +Nothing +} +} +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-testClass-clone}{}}} +\subsection{Method \code{clone()}}{ +The objects of this class are cloneable with this method. +\subsection{Usage}{ +\if{html}{\out{
}}\preformatted{testClass$clone(deep = FALSE)}\if{html}{\out{
}} +} + +\subsection{Arguments}{ +\if{html}{\out{
}} +\describe{ +\item{\code{deep}}{Whether to make a deep clone.} +} +\if{html}{\out{
}} +} +} +} diff --git a/inst/package_report/package_vignette_template.Rmd b/inst/package_report/package_vignette_template.Rmd index 3bcb2c06..8e342140 100644 --- a/inst/package_report/package_vignette_template.Rmd +++ b/inst/package_report/package_vignette_template.Rmd @@ -4,7 +4,7 @@ output: rmarkdown::html_vignette: toc: true vignette: > - %\VignetteIndexEntry{Package Report, by pkgnet} + %\VignetteIndexEntry{ {{pkg_name}} Package Report, by pkgnet } %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- diff --git a/tests/testthat/test-0-test-package-installation.R b/tests/testthat/test-0-test-package-installation.R index afb6aba7..51dbebbf 100644 --- a/tests/testthat/test-0-test-package-installation.R +++ b/tests/testthat/test-0-test-package-installation.R @@ -3,7 +3,7 @@ # correctly and being available. test_that('Test packages installed correctly',{ - testPkgNames <- c("baseballstats", "sartre", "milne", "silverstein") + testPkgNames <- c("baseballstats", "sartre", "milne", "silverstein","control") for (thisTestPkg in testPkgNames) { expect_true( object = require(thisTestPkg diff --git a/tests/testthat/test-CreatePackageReport.R b/tests/testthat/test-CreatePackageReport.R index 7a884323..bf1e8e46 100644 --- a/tests/testthat/test-CreatePackageReport.R +++ b/tests/testthat/test-CreatePackageReport.R @@ -132,6 +132,40 @@ test_that("CreatePackageReport respects report_path when explicitly given", { expect_true(any(grepl("Dependency Network", readLines(testing_file)))) }) +test_that("Test that CreatePackageReport runs with control statements", { + + testReportPath <- tempfile( + pattern = "control" + , fileext = ".html" + ) + + createdReport <- CreatePackageReport( + pkg_name = "control" + , report_path = testReportPath + ) + + testthat::expect_true({ + reporters <- grep("Reporter$", names(createdReport), value = TRUE) + all(vapply( + X = reporters + , FUN = function(x) { + is.null(createdReport[[x]]) | inherits(createdReport[[x]], "AbstractPackageReporter") + } + , FUN.VALUE = logical(1) + )) + }) + testthat::expect_true(file.exists(testReportPath) && file.size(testReportPath) > 0) + testthat::expect_true(inherits(createdReport, "PackageReport")) + testthat::expect_true( + all( + vapply(DefaultReporters(), function(x){class(x)[1]}, FUN.VALUE = character(1)) + %in% names(createdReport) + ) + , info = "Returned report object doesn't have reporters accessible") + file.remove(testReportPath) +}) + + ##### TEST TEAR DOWN ##### Sys.unsetenv("PKGNET_SUPPRESS_BROWSER") diff --git a/tests/testthat/test-CreatePackageVignette.R b/tests/testthat/test-CreatePackageVignette.R index 9cea5245..44d88762 100644 --- a/tests/testthat/test-CreatePackageVignette.R +++ b/tests/testthat/test-CreatePackageVignette.R @@ -174,51 +174,3 @@ test_that("Test that CreatePackageVignette errors for bad inputs", { , fixed = TRUE ) }) - -test_that("CreatePackageVignette warns if vignette_path seems wrong", { - - pkgPath <- .CreateSourceCopy(sourcePath) - on.exit(expr = unlink(pkgPath, recursive = TRUE)) - - # In a vignettes directory that isn't in a package root - vignettesDir <- file.path(tempdir(), "vignettes") - dir.create(vignettesDir) - expect_warning( - CreatePackageVignette(pkg = pkgPath - , vignette_path = file.path(vignettesDir - , "pkgnet_report.Rmd") - ) - , regexp = paste("not inside a package root directory") - , fixed = TRUE - ) - # Clean up - unlink(file.path(tempdir(), "vignettes"), recursive = TRUE) - - # If in root of a different package - suppressWarnings({ - # creating a temporary environment to avoid the following error from package.skeleton() - # "... no R objects specified or available" - basketball_env <- new.env() - basketball_env[["a"]] <- function(){return(1)} - utils::package.skeleton( - name = "basketballstats" - , environment = basketball_env - , path = tempdir() - ) - }) - dir.create(file.path(tempdir(), "basketballstats", "vignettes")) - expect_warning( - CreatePackageVignette(pkg = pkgPath - , vignette_path = file.path(tempdir() - , "basketballstats" - , "vignettes" - , "pkgnet_report.Rmd") - ) - , regexp = paste("You are writing a report for baseballstats to the" - , "vignettes directory for basketballstats") - , fixed = TRUE - ) - # Clean up - unlink(file.path(tempdir(), "basketballstats"), recursive = TRUE) - -}) diff --git a/tests/testthat/test-FunctionReporter-class.R b/tests/testthat/test-FunctionReporter-class.R index eca52f6e..fdb6cc51 100644 --- a/tests/testthat/test-FunctionReporter-class.R +++ b/tests/testthat/test-FunctionReporter-class.R @@ -242,6 +242,42 @@ test_that(".parse_function correctly ignores right side of list extraction", { }) }) +test_that(".parse_function correctly handles break control statement", { + # Correctly parses body of function and finds all function symbols + expect_true({ + myfunc <- function() { + x <- innerfunc1() + y <- innerfunc2() + z <- innerfunc3(innerfunc4()) + for (i in 1:10){ + if(i==5){ + break + } + } + } + result <- pkgnet:::.parse_function(body(myfunc)) + all(c("innerfunc1", "innerfunc2", "innerfunc3", "innerfunc4") %in% result) + }) +}) + +test_that(".parse_function correctly handles next control statement", { + # Correctly parses body of function and finds all function symbols + expect_true({ + myfunc <- function() { + x <- innerfunc1() + y <- innerfunc2() + z <- innerfunc3(innerfunc4()) + for (i in 1:10){ + if(i==5){ + next + } + } + } + result <- pkgnet:::.parse_function(body(myfunc)) + all(c("innerfunc1", "innerfunc2", "innerfunc3", "innerfunc4") %in% result) + }) +}) + test_that(".parse_R6_expression correctly parses expressions for symbols", { # Correctly parses body of function and finds all function symbols expect_true({ @@ -268,6 +304,51 @@ test_that(".parse_R6_expression correctly ignores right side of list extraction" }) }) +test_that(".parse_R6_expression correctly parses expressions containing a break statement", { + # Correctly parses body of function and finds all function symbols + expect_true({ + myr6method <- function() { + x <- regularfunc1() + z <- regularfunc2(regularfunc3()) + self$public_method() + self$active_binding <- "new_value" + private$private_method + for (i in 1:10){ + if(i==5){ + break + } + } + 2+2 + } + result <- pkgnet:::.parse_R6_expression(body(myr6method)) + all(c("regularfunc1", "regularfunc2", "regularfunc3", "self$public_method" + , "self$active_binding", "private$private_method" + ) %in% result) + }) +}) + +test_that(".parse_R6_expression correctly parses expressions containing a next statements", { + # Correctly parses body of function and finds all function symbols + expect_true({ + myr6method <- function() { + x <- regularfunc1() + z <- regularfunc2(regularfunc3()) + self$public_method() + self$active_binding <- "new_value" + private$private_method + for (i in 1:10){ + if(i==5){ + next + } + } + 2+2 + } + result <- pkgnet:::.parse_R6_expression(body(myr6method)) + all(c("regularfunc1", "regularfunc2", "regularfunc3", "self$public_method" + , "self$active_binding", "private$private_method" + ) %in% result) + }) +}) test_that("FunctionReporter R6 edge extraction handles case where all methods have the same number of dependencies", {