diff --git a/.Rbuildignore b/.Rbuildignore index 3c7b99d..2452b83 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -2,6 +2,7 @@ ^\..*/ ^\.Rproj\.user$ .*_cache/ +^\.github$ ^data-raw/ ^inst/snippets/ ^revdep/ @@ -16,16 +17,10 @@ ^CRAN-RELEASE$ ^README\.Rmd$ ^LICENSE\.md$ -^vignettes/_common.R$ -^vignettes/references.bib$ - -# Docker -^docker-compose\.yml$ -^R/utils-DockerCompose\.R$ # pkgdown$ ^docs$ ^pkgdown$ - - +# cran +^CRAN-SUBMISSION$ diff --git a/.Rprofile b/.Rprofile index 4e6aacc..e5223d6 100644 --- a/.Rprofile +++ b/.Rprofile @@ -1,71 +1,22 @@ assign(".Rprofile", new.env(), envir = globalenv()) # .First ------------------------------------------------------------------ -.First <- function(){ - try(if(testthat::is_testing()) return()) - try(readRenviron(".Renviron"), silent = TRUE) +.First <- function() { + try(if (testthat::is_testing()) { + return() + }, silent = TRUE) + if (file.exists(".Renviron")) readRenviron(".Renviron") - # Package Management System - Date <- as.character(read.dcf("DESCRIPTION", "Date")); - URL <- if(is.na(Date)) "https://cran.rstudio.com/" else paste0("https://mran.microsoft.com/snapshot/", Date) - options(repos = URL) -} - -# .Last ------------------------------------------------------------------- -.Last <- function(){ - try(if(testthat::is_testing()) return()) - try(system('docker-compose down'), silent = TRUE) -} - -# Docker ------------------------------------------------------------------ -.Rprofile$docker$browse_url <- function(service){ - path_script <- tempfile("system-", fileext = ".R") - job_name <- paste("Testing", as.character(read.dcf('DESCRIPTION', 'Package')), "in a Docker Container") - define_service <- paste0("service = c(", paste0(paste0("'",service,"'"), collapse = ", "),")") - define_service <- if(is.null(service)) "service = NULL" else define_service - writeLines(c( - "source('./R/utils-DockerCompose.R')", - define_service, - "DockerCompose$new()$browse_url(service)"), path_script) - .Rprofile$utils$run_script(path_script, job_name) -} - -.Rprofile$docker$start <- function(service = NULL){ - path_script <- tempfile("system-", fileext = ".R") - job_name <- paste("Testing", as.character(read.dcf('DESCRIPTION', 'Package')), "in a Docker Container") - define_service <- paste0("service <- c(", paste0(paste0("'",service,"'"), collapse = ", "),")") - define_service <- if(is.null(service)) "service = NULL" else define_service - writeLines(c( - "source('./R/utils-DockerCompose.R')", - define_service, - "DockerCompose$new()$start(service)"), path_script) - .Rprofile$utils$run_script(path_script, job_name) -} -.Rprofile$docker$stop <- function(){ - path_script <- tempfile("system-", fileext = ".R") - job_name <- paste("Testing", as.character(read.dcf('DESCRIPTION', 'Package')), "in a Docker Container") - writeLines(c("source('./R/utils-DockerCompose.R'); DockerCompose$new()$stop()"), path_script) - .Rprofile$utils$run_script(path_script, job_name) -} - -.Rprofile$docker$restart <- function(service = NULL){ - path_script <- tempfile("system-", fileext = ".R") - job_name <- paste("Testing", as.character(read.dcf('DESCRIPTION', 'Package')), "in a Docker Container") - define_service <- paste0("service <- c(", paste0(paste0("'",service,"'"), collapse = ", "),")") - define_service <- if(is.null(service)) "service = NULL" else define_service - writeLines(c( - "source('./R/utils-DockerCompose.R')", - define_service, - "DockerCompose$new()$restart(service)"), path_script) - .Rprofile$utils$run_script(path_script, job_name) -} - -.Rprofile$docker$reset <- function(){ - path_script <- tempfile("system-", fileext = ".R") - job_name <- paste("Testing", as.character(read.dcf('DESCRIPTION', 'Package')), "in a Docker Container") - writeLines(c("source('./R/utils-DockerCompose.R'); DockerCompose$new()$reset()"), path_script) - .Rprofile$utils$run_script(path_script, job_name) + # Package Management System + r_version_date <- gsub(".*\\((\\d{4}-\\d{2}-\\d{2}).*", "\\1", R.Version()$version.string) + r_package_date <- as.character(read.dcf("DESCRIPTION", "Date")) + r_cran_date <- ifelse(is.na(r_package_date), r_version_date, r_package_date) + options(repos = c(CRAN = paste0("https://packagemanager.rstudio.com/cran/", r_cran_date))) + + # Options + Sys.setenv(`_R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_` = "false") + Sys.setenv(`_R_CHECK_SYSTEM_CLOCK_` = 0) } # pkgdown ----------------------------------------------------------------- @@ -124,3 +75,9 @@ assign(".Rprofile", new.env(), envir = globalenv()) invisible() } +# .Last ------------------------------------------------------------------- +.Last <- function() { + try(if (testthat::is_testing()) { + return() + }) +} diff --git a/.dev/CRAN/prepare-for-release.R b/.dev/CRAN/prepare-for-release.R index a77b2e4..c5654b1 100644 --- a/.dev/CRAN/prepare-for-release.R +++ b/.dev/CRAN/prepare-for-release.R @@ -6,6 +6,14 @@ Sys.setenv(`_R_DEPENDS_ONLY` = "true") remotes::install_cran(c("devtools", "urlchecker", "rhub", "revdepcheck")) # remotes::install_github("r-lib/revdepcheck@master") +# Printing Code ----------------------------------------------------------- +# Lint the package +(report = lintr::lint_package(show_progress = TRUE)) +styler::style_pkg( + filetype = c("R", "Rprofile", "Rmd", "Rmarkdown", "Rnw", "qmd")[c(1,3)], + exclude_dirs = c("packrat", "renv", ".dev", ".git", ".github", ".Rproj.user", "docs", "inst"), + include_roxygen_examples = TRUE, +) # Steps ------------------------------------------------------------------- # devtools::build_readme() diff --git a/.dev/docker/r-test/Dockerfile b/.dev/docker/r-test/Dockerfile deleted file mode 100644 index 958a484..0000000 --- a/.dev/docker/r-test/Dockerfile +++ /dev/null @@ -1,31 +0,0 @@ -# R Package Development: Core -------------------------------------------------- -FROM tidylab/package:4.1.0 - -# Install Project Dependencies ------------------------------------------------- -COPY ./DESCRIPTION ./DESCRIPTION -RUN R -q -e "install_deps(dependencies = 'Depends')" -RUN R -q -e "install_deps(dependencies = 'Imports')" -RUN R -q -e "install_deps(dependencies = 'Suggests')" - -# R Package Development: Testing------------------------------------------------ -RUN touch .Renviron .Rprofile -RUN echo "" > .Rprofile - -# Prepare Package Files -------------------------------------------------------- -ARG R_USER=./home/rstudio/ -ARG R_PACKAGE_NAME=rproject -COPY . ${R_USER}/${R_PACKAGE_NAME} -RUN cp .Rprofile ${R_USER}/${R_PACKAGE_NAME} -RUN cp .env ${R_USER}/.Renviron -WORKDIR ${R_USER}/${R_PACKAGE_NAME} - -# Test-Suite ------------------------------------------------------------------- -RUN R -q -e "system.time(devtools::document())" -RUN R -q -e "system.time(devtools::check(error_on = 'note'))" -RUN R -q -e "system.time({\ - devtools::load_all(export_all = FALSE, helpers = FALSE);\ - testthat::test_dir('./tests/testthat', stop_on_failure = TRUE)\ - })" - -# Teardown --------------------------------------------------------------------- -ENTRYPOINT /bin/bash diff --git a/.dockerignore b/.dockerignore deleted file mode 100644 index 4bc4847..0000000 --- a/.dockerignore +++ /dev/null @@ -1,15 +0,0 @@ -# Folders -.*/ -cache/ -inst/docs/ -man/ -vignettes/_cache/ - -# Files -.* -!.Rbuildignore -^docker-compose.yml$ - -# Demo -./R/demo-* -./tests/testthat/test-demo-* diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml new file mode 100644 index 0000000..d05eda5 --- /dev/null +++ b/.github/workflows/R-CMD-check.yaml @@ -0,0 +1,41 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + pull_request: + +name: R-CMD-check + +permissions: read-all + +jobs: + R-CMD-check: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + R_KEEP_PKG_SOURCE: yes + steps: + - name: Remove .Rprofile + # Delete .Rprofile if present. + run: rm -f ./.Rprofile + + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::rcmdcheck, any::roxygen2 + needs: check + + - name: Document the package + run: | + roxygen2::roxygenise() + shell: Rscript {0} + + - uses: r-lib/actions/check-r-package@v2 + with: + upload-snapshots: true + build_args: 'c("--no-manual","--compact-vignettes=gs+qpdf")' diff --git a/.github/workflows/R-CMD-check.yml b/.github/workflows/R-CMD-check.yml deleted file mode 100644 index c60e9d5..0000000 --- a/.github/workflows/R-CMD-check.yml +++ /dev/null @@ -1,98 +0,0 @@ -# For help debugging build failures open an issue on the RStudio community with the 'github-actions' tag. -# https://community.rstudio.com/new-topic?category=Package%20development&tags=github-actions -on: - push: - # branches: - # - master - pull_request: - branches: - - master - - develop - -name: R-CMD-check - -jobs: - R-CMD-check: - runs-on: ${{ matrix.config.os }} - - name: ${{ matrix.config.os }} (${{ matrix.config.r }}) - - strategy: - fail-fast: false - matrix: - config: - - {os: windows-latest, r: 'release'} - - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - {os: ubuntu-20.04, r: 'devel', rspm: "https://packagemanager.rstudio.com/cran/__linux__/focal/latest"} - - env: - R_REMOTES_NO_ERRORS_FROM_WARNINGS: true - R_COMPILE_AND_INSTALL_PACKAGES: always - RSPM: ${{ matrix.config.rspm }} - GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} - NOT_CRAN: false - - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@v1 - with: - r-version: ${{ matrix.config.r }} - - - uses: r-lib/actions/setup-pandoc@v1 - - - name: Prepare - run: | - echo "utils::chooseCRANmirror(graphics=FALSE, ind = 1)" > .Rprofile - Rscript -e "Date <- as.character(read.dcf('DESCRIPTION', 'Date')); - URL <- if(is.na(Date)) 'https://cran.rstudio.com/' else paste0('https://mran.microsoft.com/snapshot/', Date); - Rprofile <- file('.Rprofile', open = 'wt'); - writeLines('.libPaths(Sys.getenv(\'R_LIBS_USER\'))', Rprofile); - writeLines('require(remotes)', Rprofile); - writeLines(paste0('options(repos = \'', URL, '\')'), Rprofile); - close(Rprofile)" - Rscript -e "if(!'remotes' %in% rownames(utils::installed.packages())) utils::install.packages('remotes')" - - name: Query dependencies - run: | - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - if: runner.os != 'Windows' - uses: actions/cache@v2 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install system dependencies - if: runner.os == 'Linux' - run: | - while read -r cmd - do - eval sudo $cmd - done < <(Rscript -e 'writeLines(remotes::system_requirements("ubuntu", "20.04"))') - sudo apt-get install build-essential libcurl4-gnutls-dev libxml2-dev libssl-dev libgit2-dev - - - name: Install dependencies - run: | - remotes::install_deps(dependencies = TRUE) - remotes::install_cran(c("devtools", "rcmdcheck", "rmarkdown")) - shell: Rscript {0} - - - name: Check - env: - _R_CHECK_CRAN_INCOMING_REMOTE_: false - run: | - devtools::document() - rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning", check_dir = "check") - shell: Rscript {0} - - - name: Upload check results - if: failure() - uses: actions/upload-artifact@main - with: - name: ${{ runner.os }}-r${{ matrix.config.r }}-results - path: check diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml new file mode 100644 index 0000000..6290568 --- /dev/null +++ b/.github/workflows/pkgdown.yaml @@ -0,0 +1,64 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: #[main, master] + pull_request: + release: + types: [published] + workflow_dispatch: + +name: pkgdown + +permissions: read-all + +jobs: + pkgdown: + runs-on: ubuntu-latest + # Only restrict concurrency for non-PR jobs + concurrency: + group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + permissions: + contents: write + steps: + - name: Remove .Rprofile + # Delete .Rprofile if present. + run: rm -f ./.Rprofile + + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-pandoc@v2 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: | + any::pkgdown, + any::roxygen2, + any::covr, + any::usethis, + any::pkgload, + local::., + needs: website + + - name: Build site + run: | + roxygen2::roxygenise() + rmarkdown::render("README.Rmd", output_format = "md_document") + pkgload::load_all() + pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) + covr::codecov(type = "all") + shell: Rscript {0} + + - name: Deploy to GitHub pages 🚀 + if: github.event_name != 'pull_request' + uses: JamesIves/github-pages-deploy-action@v4.5.0 + with: + clean: false + branch: gh-pages + folder: docs diff --git a/.github/workflows/pkgdown.yml b/.github/workflows/pkgdown.yml deleted file mode 100644 index 85c1cdd..0000000 --- a/.github/workflows/pkgdown.yml +++ /dev/null @@ -1,65 +0,0 @@ -on: - push: - branches: - - master - - release/* - -name: pkgdown - -jobs: - pkgdown: - runs-on: macOS-latest - env: - GITHUB_PAT: ${{ secrets.PKGDOWN_PAT }} - _R_S3_METHOD_REGISTRATION_NOTE_OVERWRITES_: false - steps: - - uses: actions/checkout@v2 - - - uses: r-lib/actions/setup-r@master - - - uses: r-lib/actions/setup-pandoc@master - - - uses: r-lib/actions/setup-tinytex@v1 - - - name: Install system dependencies - run: | - brew install harfbuzz fribidi libgit2 - rm .Rprofile - - - name: Prepare - run: | - echo "utils::chooseCRANmirror(graphics=FALSE, ind = 1)" > .Rprofile - Rscript -e "if(!'remotes' %in% rownames(utils::installed.packages())) utils::install.packages('remotes')" - - - name: Query dependencies - run: | - pkgs <- remotes::dev_package_deps(dependencies = TRUE); print(pkgs[order(pkgs$package),]) - saveRDS(remotes::dev_package_deps(dependencies = TRUE), ".github/depends.Rds", version = 2) - writeLines(sprintf("R-%i.%i", getRversion()$major, getRversion()$minor), ".github/R-version") - shell: Rscript {0} - - - name: Cache R packages - uses: actions/cache@v1 - with: - path: ${{ env.R_LIBS_USER }} - key: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1-${{ hashFiles('.github/depends.Rds') }} - restore-keys: ${{ runner.os }}-${{ hashFiles('.github/R-version') }}-1- - - - name: Install dependencies - run: | - sapply(c("tidyverse", "devtools", "pkgdown", "covr"), function(x) try(remotes::install_cran(x))) - remotes::update_packages("pkgdown") - remotes::install_deps(dependencies = TRUE) - shell: Rscript {0} - - - name: Install package - run: R CMD INSTALL . - - - name: Deploy website - run: | - git config --local user.email "actions@github.com" - git config --local user.name "GitHub Actions" - Rscript -e 'devtools::document()' - Rscript -e 'rmarkdown::render("README.Rmd", "md_document")' - Rscript -e 'pkgdown::deploy_to_branch(new_process = FALSE)' - Rscript -e 'covr::codecov(type = "all")' diff --git a/CRAN-SUBMISSION b/CRAN-SUBMISSION new file mode 100644 index 0000000..575fa14 --- /dev/null +++ b/CRAN-SUBMISSION @@ -0,0 +1,3 @@ +Version: 0.4.0 +Date: 2024-12-22 09:21:16 UTC +SHA: c2d1fa17cf445540e3b607f12d4b9fa36a91c80a diff --git a/DESCRIPTION b/DESCRIPTION index 07c039c..5b7d82e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,44 +1,42 @@ -Package: R6P -Type: Package -Title: Design Patterns in R -URL: https://tidylab.github.io/R6P/, https://github.com/tidylab/R6P -BugReports: https://github.com/tidylab/R6P/issues -Version: 0.2.2 -Date: 2021-08-01 -Authors@R: c( - person("Harel", "Lustiger", email = "tidylab@gmail.com", role = c("aut", "cre"), - comment = c(ORCID = "0000-0003-2953-9598")), - person("Tidylab", role = c("cph", "fnd")) - ) -Maintainer: Harel Lustiger -Description: Build robust and maintainable software with object-oriented design - patterns in R. Design patterns abstract and present in neat, well-defined - components and interfaces the experience of many software designers and - architects over many years of solving similar problems. These are solutions - that have withstood the test of time with respect to re-usability, - flexibility, and maintainability. 'R6P' provides abstract base classes with - examples for a few known design patterns. The patterns were selected by - their applicability to analytic projects in R. Using these patterns in R - projects have proven effective in dealing with the complexity that - data-driven applications possess. -License: MIT + file LICENSE -Encoding: UTF-8 -RoxygenNote: 7.1.1 -Roxygen: list(markdown = TRUE, r6 = TRUE) -Language: en-GB -Depends: - R (>= 3.5) -Suggests: - testthat, - DBI, - RSQLite, - ggplot2 -Imports: - collections, - dplyr, - purrr, - stringr, - R6, - tibble, - tidyr -Config/testthat/edition: 3 +Package: R6P +Type: Package +Title: Design Patterns in R +URL: https://tidylab.github.io/R6P/, https://github.com/tidylab/R6P +BugReports: https://github.com/tidylab/R6P/issues +Version: 0.4.0 +Authors@R: c( + person("Harel", "Lustiger", email = "tidylab@gmail.com", role = c("aut", "cre"), + comment = c(ORCID = "0000-0003-2953-9598")), + person("Tidylab", role = c("cph", "fnd")) + ) +Maintainer: Harel Lustiger +Description: Build robust and maintainable software with object-oriented design + patterns in R. Design patterns abstract and present in neat, well-defined + components and interfaces the experience of many software designers and + architects over many years of solving similar problems. These are solutions + that have withstood the test of time with respect to re-usability, + flexibility, and maintainability. 'R6P' provides abstract base classes with + examples for a few known design patterns. The patterns were selected by + their applicability to analytic projects in R. Using these patterns in R + projects have proven effective in dealing with the complexity that + data-driven applications possess. +License: MIT + file LICENSE +Encoding: UTF-8 +RoxygenNote: 7.3.2 +Roxygen: list(markdown = TRUE, r6 = TRUE) +Language: en-GB +Depends: + R (>= 4.1) +Suggests: + testthat, + DBI, + RSQLite, + ggplot2 +Imports: + collections, + dplyr, + stringr, + R6, + tibble, + tidyr +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index eb76308..731233a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,10 +1,6 @@ # Generated by roxygen2: do not edit by hand -export("%>%") -export("%||%") export(AbstractRepository) export(NullObject) export(Singleton) export(ValueObject) -importFrom(purrr,"%>%") -importFrom(purrr,"%||%") diff --git a/NEWS.md b/NEWS.md index e8f9ce4..9cc1b93 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# R6P 0.4.0 + +- Dropped dependency on `purrr` package +- Uses "|>" and therefore requires R 4.1.0 +- Revamp function documentation to pass CRAN checks + # R6P 0.2.1 - Update system files diff --git a/R/R6P-helpers.R b/R/R6P-helpers.R index f0e8fc0..31142ac 100644 --- a/R/R6P-helpers.R +++ b/R/R6P-helpers.R @@ -1,27 +1,31 @@ # Helper Functions -------------------------------------------------------- -get_classname <- function(){ - calls <- as.character(sys.calls()) - calls <- calls[max(which(stringr::str_detect(calls, "\\$new\\(.*\\)")))] - stopifnot(length(calls) == 1) +get_classname <- function() { + calls <- as.character(sys.calls()) + calls <- calls[max(which(stringr::str_detect(calls, "\\$new\\(.*\\)")))] + stopifnot(length(calls) == 1) - classname <- stringr::str_remove(calls, "\\$new\\(.*\\)") - return(classname) + classname <- stringr::str_remove(calls, "\\$new\\(.*\\)") + return(classname) } -dynGet <- function(x, ...){ - tryCatch( - base::dynGet(x, ...), - error = function(e){ return(base::get(x, ...)) } - ) +dynGet <- function(x, ...) { + tryCatch( + base::dynGet(x, ...), + error = function(e) { + return(base::get(x, ...)) + } + ) } -dynSet <- function(key, value){ - n <- sys.nframe() - for(i in seq_len(n-1)) - if(any(key %in% ls(envir = parent.frame(i)))) - assign(key, value, envir = parent.frame(i)) +dynSet <- function(key, value) { + n <- sys.nframe() + for (i in seq_len(n - 1)) { + if (any(key %in% ls(envir = parent.frame(i)))) { + assign(key, value, envir = parent.frame(i)) + } + } - return() + return() } # Exception Handling ------------------------------------------------------ @@ -31,7 +35,6 @@ dynSet <- function(key, value){ exceptions <- new.env() exceptions$not_implemented_error <- function() { - caller_name <- deparse(sys.calls()[[sys.nframe()-2]]) - stop(paste(caller_name, "is not implmented")) + caller_name <- deparse(sys.calls()[[sys.nframe() - 2]]) + stop(paste(caller_name, "is not implmented")) } - diff --git a/R/R6P-package.R b/R/R6P-package.R new file mode 100644 index 0000000..5bbc4d5 --- /dev/null +++ b/R/R6P-package.R @@ -0,0 +1,13 @@ +#' @keywords internal +"_PACKAGE" + +## usethis namespace: start +## usethis namespace: end +NULL + +# Missing Packages Workaround +.workaround <- function() { + R6::R6Class + collections::queue + dplyr::.data +} diff --git a/R/base-NullObject.R b/R/base-NullObject.R index 3f2d9b0..6a586cf 100644 --- a/R/base-NullObject.R +++ b/R/base-NullObject.R @@ -1,5 +1,4 @@ #' @title Null Object Pattern -#' @includeRmd vignettes/details/NullObject.Rmd #' @description Model a domain concept using natural lingo of the domain #' experts, such as “Passenger”, “Address”, and “Money”. #' @family base design patterns @@ -9,6 +8,4 @@ #' #' colnames(NullObject()) #' nrow(NullObject()) -NullObject <- function() tibble::tibble(given = NA_character_, family = NA_character_)[0,] - - +NullObject <- function() tibble::tibble(given = NA_character_, family = NA_character_)[0, ] diff --git a/R/base-Singleton.R b/R/base-Singleton.R index 9372bc5..3f4da6e 100644 --- a/R/base-Singleton.R +++ b/R/base-Singleton.R @@ -1,29 +1,34 @@ -#' @title Singleton Pattern -#' @name Singleton -#' @includeRmd vignettes/details/Singleton.Rmd +#' @title Singleton +#' +#' @description +#' Enforces a single instance of a class and provides a global access point. +#' +#' @details +#' This is an abstract base class. Instantiating `Singleton` directly triggers an error. +#' Classes inheriting from `Singleton` share a single instance. +#' #' @examples #' # See more examples at -#' address <- function(x) sub('', '\\1', capture.output(x)) +#' address <- function(x) sub("", "\\1", capture.output(x)) #' -#' # In this example we implement a `Counter` that inherits the qualities of -#' # Singleton +#' # In this example we implement a `Counter` that inherits the qualities of Singleton #' Counter <- R6::R6Class("Counter", inherit = R6P::Singleton, public = list( -#' count = 0, -#' add_1 = function(){self$count = self$count + 1; invisible(self)} +#' count = 0, +#' add_1 = function() { +#' self$count <- self$count + 1 +#' invisible(self) +#' } #' )) #' -#' # Whenever we call the constructor on `Counter`, we always get the exact same -#' # instance: +#' # Whenever we call the constructor on `Counter`, we always get the exact same instance: #' counter_A <- Counter$new() #' counter_B <- Counter$new() #' #' identical(counter_A, counter_B, ignore.environment = FALSE) #' -#' # The two objects are equal and located at the same address; thus, they are -#' # the same object. +#' # The two objects are equal and located at the same address; thus, they are the same object. #' -#' # When we make a change in any of the class instances, the rest of the -#' # instances are changed as well. +#' # When we make a change in any of the class instances, the rest are changed as well. #' #' # How many times has the counter been increased? #' counter_A$count @@ -34,37 +39,36 @@ #' # How many times have the counters been increased? #' counter_A$count #' counter_B$count -NULL - -#' @rdname Singleton -#' @description Ensure a class only has one instance, and provide a global point -#' of access to it. +#' #' @family base design patterns #' @export -Singleton <- R6::R6Class("Singleton", cloneable = FALSE, public = list( +Singleton <- R6::R6Class( + "Singleton", + cloneable = FALSE, + public = list( #' @description Create or retrieve an object - initialize = function(){ - classname <- get_classname() - if(classname == "Singleton") stop(paste(classname, "is an abstract base class and therefore cannot be instantiated directly")) - if(is.null(private$public_bind_env)){ - Class <- private$dynGet(classname) - - private$public_bind_env <- private$dynGet("public_bind_env") - private$private_bind_env <- private$dynGet("private_bind_env") - - Class$set('private', 'public_bind_env', private$public_bind_env, overwrite = TRUE) - Class$set('private', 'private_bind_env', private$private_bind_env, overwrite = TRUE) - - } else { - self <- private$instance - private$dynSet("public_bind_env", private$public_bind_env) - private$dynSet("private_bind_env", private$private_bind_env) - } + initialize = function() { + classname <- get_classname() + if (classname == "Singleton") { + stop(paste(classname, "is an abstract base class and cannot be instantiated directly")) + } + if (is.null(private$public_bind_env)) { + Class <- private$dynGet(classname) + private$public_bind_env <- private$dynGet("public_bind_env") + private$private_bind_env <- private$dynGet("private_bind_env") + Class$set("private", "public_bind_env", private$public_bind_env, overwrite = TRUE) + Class$set("private", "private_bind_env", private$private_bind_env, overwrite = TRUE) + } else { + self <- private$instance + private$dynSet("public_bind_env", private$public_bind_env) + private$dynSet("private_bind_env", private$private_bind_env) + } } -), private = list( + ), + private = list( public_bind_env = NULL, private_bind_env = NULL, dynGet = dynGet, dynSet = dynSet -)) - + ) +) diff --git a/R/base-ValueObject.R b/R/base-ValueObject.R index a41800b..565485b 100644 --- a/R/base-ValueObject.R +++ b/R/base-ValueObject.R @@ -1,11 +1,14 @@ #' @title Value Object Pattern -#' @includeRmd vignettes/details/ValueObject.Rmd -#' @description Model a domain concept using natural lingo of the domain -#' experts, such as “Passenger”, “Address”, and “Money”. +#' +#' @description +#' Model a domain concept using natural lingo of domain experts, such as “Passenger,” “Address,” or “Money.” +#' #' @param given (`character`) A character vector with the given name. #' @param family (`character`) A character vector with the family name. +#' #' @family base design patterns #' @export +#' #' @examples #' # See more examples at #' @@ -19,56 +22,48 @@ #' # * Check that the input argument has all the columns that a Person has #' is.Person <- function(x) all(colnames(x) %in% colnames(Person())) #' -#' # A 'Minister' is a 'Person' with a ministry title. We capture that information -#' # in a new Value Object named 'Minister'. -# -#' # The Minister constructor requires two inputs: +#' # A 'Minister' is a 'Person' with a ministry title. The Minister constructor +#' # requires two inputs: #' # 1. (`Person`) Members of parliament #' # 2. (`character`) Ministry titles -#' Minister <- function(member = Person(), title = NA_character_){ -#' stopifnot(is.Person(member), is.character(title)) -#' stopifnot(nrow(member) == length(title) | all(is.na(title))) +#' Minister <- function(member = Person(), title = NA_character_) { +#' stopifnot(is.Person(member), is.character(title)) +#' stopifnot(nrow(member) == length(title) | all(is.na(title))) #' -#' member %>% dplyr::mutate(title = title) -#'} +#' member |> dplyr::mutate(title = title) +#' } #' #' # Given one or more parliament members #' # When appoint_random_ministries is called #' # Then the parliament members are appointed to an office. -#' appoint_random_ministries <- function(member = Person()){ -#' positions <- c( -#' "Arts, Culture and Heritage", "Finance", "Corrections", -#' "Racing", "Sport and Recreation", "Housing", "Energy and Resources", -#' "Education", "Public Service", "Disability Issues", "Environment", -#' "Justice", "Immigration", "Defence", "Internal Affairs", "Transport" -#' ) +#' appoint_random_ministries <- function(member = Person()) { +#' positions <- c( +#' "Arts, Culture and Heritage", "Finance", "Corrections", "Racing", +#' "Sport and Recreation", "Housing", "Energy and Resources", "Education", +#' "Public Service", "Disability Issues", "Environment", "Justice", +#' "Immigration", "Defence", "Internal Affairs", "Transport" +#' ) #' -#' Minister(member = member, title = sample(positions, size = nrow(member))) +#' Minister(member = member, title = sample(positions, size = nrow(member))) #' } #' -#' # Listing New Zealand elected officials in 2020, we instantiate a Person Object, -#' # appoint them to random offices and return a Member value object. +#' # Listing New Zealand elected officials in 2020, we instantiate a Person object, +#' # appoint them to random offices, and return a Minister value object. #' set.seed(2020) -#' #' parliament_members <- Person( -#' given = c("Jacinda", "Grant", "Kelvin", "Megan", "Chris", "Carmel"), -#' family = c("Ardern", "Robertson", "Davis", "Woods", "Hipkins", "Sepuloni") +#' given = c("Jacinda", "Grant", "Kelvin", "Megan", "Chris", "Carmel"), +#' family = c("Ardern", "Robertson", "Davis", "Woods", "Hipkins", "Sepuloni") #' ) #' #' parliament_members -#' #' appoint_random_ministries(member = parliament_members) -ValueObject <- function( - given = NA_character_, - family = NA_character_ -){ - stopifnot(is.character(given), is.character(family)) - stopifnot(length(given) == length(family) | all(is.na(family))) +ValueObject <- function(given = NA_character_, + family = NA_character_) { + stopifnot(is.character(given), is.character(family)) + stopifnot(length(given) == length(family) | all(is.na(family))) - tibble::tibble( - given = given %>% stringr::str_to_title(), - family = family %>% stringr::str_to_title() - ) %>% tidyr::drop_na(given) + tibble::tibble( + given = given |> stringr::str_to_title(), + family = family |> stringr::str_to_title() + ) |> tidyr::drop_na(given) } - - diff --git a/R/object_relational-Repository.R b/R/object_relational-Repository.R index fbf2b30..611b868 100644 --- a/R/object_relational-Repository.R +++ b/R/object_relational-Repository.R @@ -1,6 +1,5 @@ #' @title Repository Pattern #' @name Repository -#' @includeRmd vignettes/details/Repository.Rmd #' @examples #' # See more examples at #' @@ -20,27 +19,42 @@ #' # predefined column. #' #' TransientRepository <- R6::R6Class( -#' classname = "Repository", inherit = R6P::AbstractRepository, public = list( -#' initialize = function() {private$cars <- collections::dict()}, -#' add = function(key, value){private$cars$set(key, value); invisible(self)}, -#' del = function(key){private$cars$remove(key); invisible(self)}, -#' get = function(key){return(private$cars$get(key, default = private$NULL_car))} -#' ), private = list( -#' NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0,], -#' cars = NULL -#' )) +#' classname = "Repository", inherit = R6P::AbstractRepository, public = list( +#' initialize = function() { +#' private$cars <- collections::dict() +#' }, +#' add = function(key, value) { +#' private$cars$set(key, value) +#' invisible(self) +#' }, +#' del = function(key) { +#' private$cars$remove(key) +#' invisible(self) +#' }, +#' get = function(key) { +#' return(private$cars$get(key, default = private$NULL_car)) +#' } +#' ), private = list( +#' NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0, ], +#' cars = NULL +#' ) +#' ) #' #' # Adding customised operations is also possible via the R6 set function. #' # The following example, adds a query that returns all the objects in the database #' -#' TransientRepository$set("public", "get_all_cars", overwrite = TRUE, function(){ -#' result <- private$cars$values() %>% dplyr::bind_rows() -#' if(nrow(result) == 0) return(private$NULL_car) else return(result) +#' TransientRepository$set("public", "get_all_cars", overwrite = TRUE, function() { +#' result <- private$cars$values() |> dplyr::bind_rows() +#' if (nrow(result) == 0) { +#' return(private$NULL_car) +#' } else { +#' return(result) +#' } #' }) #' #' # In this example, we use the mtcars dataset with a uid column that uniquely #' # identifies the different cars in the Repository: -#' mtcars <- datasets::mtcars %>% tibble::rownames_to_column("uid") +#' mtcars <- datasets::mtcars |> tibble::rownames_to_column("uid") #' head(mtcars, 2) #' #' # Here is how the caller uses the Repository: @@ -76,14 +90,13 @@ NULL #' @export # nocov start AbstractRepository <- R6::R6Class("Repository", inherit = Singleton, cloneable = FALSE, public = list( - #' @description Instantiate an object - initialize = function() exceptions$not_implemented_error(), - #' @description Add an element to the Repository. - add = function(key, value) exceptions$not_implemented_error(), - #' @description Delete an element from the Repository. - del = function(key) exceptions$not_implemented_error(), - #' @description Retrieve an element from the Repository. - get = function(key) exceptions$not_implemented_error() + #' @description Instantiate an object + initialize = function() exceptions$not_implemented_error(), + #' @description Add an element to the Repository. + add = function(key, value) exceptions$not_implemented_error(), + #' @description Delete an element from the Repository. + del = function(key) exceptions$not_implemented_error(), + #' @description Retrieve an element from the Repository. + get = function(key) exceptions$not_implemented_error() )) # nocov end - diff --git a/R/utils-DockerCompose.R b/R/utils-DockerCompose.R deleted file mode 100644 index 00616ce..0000000 --- a/R/utils-DockerCompose.R +++ /dev/null @@ -1,112 +0,0 @@ -# DockerCompose ----------------------------------------------------------- -#' @title Use a docker-compose.yml File -#' @description -#' GIVEN a \code{docker-compose.yml}, -#' WEHN \code{DockerCompose} is instantiated, -#' THEN the resulting object gives access to Docker commands. -#' @param service (`character`) Service name in \code{docker-compose.yml}. -#' @param field (`character`) Field name in \code{docker-compose.yml}. -#' @param slug (`character`) URL slug (e.g. \code{shiny-app-name}). -#' @family docker -#' @export -DockerCompose <- R6::R6Class(# nocov start - classname = "DockerCompose", - cloneable = FALSE, - lock_objects = FALSE, - public = list( - # Public Methods ------------------------------------------------------- - #' @description - #' Initialize a DockerCompose object - #' @param path_docker_compose (`character`) Path to docker-compose file. - initialize = function(path_docker_compose = "./docker-compose.yml"){ - stopifnot(file.exists(path_docker_compose)) - private$path_docker_compose <- path_docker_compose - private$composition <- yaml::read_yaml(path_docker_compose, eval.expr = FALSE) - invisible(self) - }, - #' @description - #' Get a value from a service - #' @examples \donttest{\dontrun{DockerCompose$new()$get("shinyserver", "ports")}} - get = function(service, field) DockerCompose$funs$get(self, private, service, field), - #' @description - #' Create and start containers. - start = function(service = NULL) DockerCompose$funs$start(self, private, service), - #' @description - #' Stop containers. - stop = function() DockerCompose$funs$stop(self, private), - #' @description - #' Restart containers. - restart = function(service = NULL) DockerCompose$funs$restart(self, private, service), - #' @description - #' Stop and remove containers, networks, images and volumes. - reset = function() DockerCompose$funs$reset(self, private), - #' @description - #' Load URL into an HTML Browser - browse_url = function(service, slug = "") DockerCompose$funs$browse_url(self, private, service, slug) - ),# end public - private = list( - path_docker_compose = c(), - composition = list() - ) -)# nocov end -DockerCompose$funs <- new.env() - -# Public Methods ---------------------------------------------------------- -DockerCompose$funs$reset <- function(self, private){ - system <- DockerCompose$funs$system - docker_commands <- c( - "docker-compose down", - "docker system prune -f", - "docker volume prune -f", - "docker network prune -f", - "docker rmi -f $(docker images -a -q)" - ) - sapply(docker_commands, function(x) try(system(x, wait = TRUE))) - invisible(self) -} - -DockerCompose$funs$restart <- function(self, private, service){ - system <- DockerCompose$funs$system - DockerCompose$funs$stop(self, private) - DockerCompose$funs$start(self, private, service) - invisible(self) -} - -DockerCompose$funs$start <- function(self, private, service){ - is.not.null <- Negate(is.null) - if(is.not.null(service)){ - service <- match.arg(service, names(private$composition$services), several.ok = TRUE) - } - - system <- DockerCompose$funs$system - docker_command <- stringr::str_glue("docker-compose up -d --build {services}", services = paste0(service, collapse = " ")) - system(docker_command, wait = TRUE) - invisible(self) -} - -DockerCompose$funs$stop <- function(self, private){ - system <- DockerCompose$funs$system - docker_command <- stringr::str_glue("docker-compose down") - system(docker_command, wait = TRUE) - invisible(self) -} - -DockerCompose$funs$browse_url <- function(self, private, service, slug){ - service <- match.arg(service, names(private$composition$services)) - url <- "localhost" - port <- stringr::str_remove(self$get(service, "ports"), ":.*") - if(length(port) == 0) port <- "8080" - address <- stringr::str_glue("http://{url}:{port}/{slug}", url = "localhost", port = port, slug = slug) - try(browseURL(utils::URLencode(address))) - return(self) -} - -DockerCompose$funs$get <- function(self, private, service, field){ - stopifnot(!missing(field)) - service <- match.arg(service, names(private$composition$services)) - private$composition$services[[service]][[field]] -} - -# Helpers ----------------------------------------------------------------- -DockerCompose$funs$system <- function(command, ...){ message("\033[43m\033[44m",command,"\033[43m\033[49m") ; base::system(command, ...) } -DockerCompose$funs$escape_character <- function(x){ if(is.character(x)) paste0('"', x, '"') else x } diff --git a/R/utils-pipes.R b/R/utils-pipes.R deleted file mode 100644 index 1e325fb..0000000 --- a/R/utils-pipes.R +++ /dev/null @@ -1,19 +0,0 @@ -#' Forward pipe operator -#' -#' @name %>% -#' @keywords internal -#' @importFrom purrr %>% -#' @usage lhs \%>\% rhs -#' @rdname pipes -#' @export -NULL - -#' NULL operator -#' -#' @name %||% -#' @keywords internal -#' @importFrom purrr %||% -#' @usage x \%||\% y -#' @rdname pipes -#' @export -NULL diff --git a/R/zzz.R b/R/zzz.R index b5732dd..1869988 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,15 +1,18 @@ -.onAttach <- function(lib, pkg,...){#nocov start - options( - usethis.quiet = TRUE - ) +.onAttach <- function(lib, pkg, ...) { # nocov start + options( + usethis.quiet = TRUE + ) - if(interactive()) packageStartupMessage( - paste( - "\n\033[44m\033[37m", - "\nWelcome to R6P", - "\nMore information, vignettes, and guides are available on the R6P project website:", - "\nhttps://tidylab.github.io/R6P/", - "\n\033[39m\033[49m", - sep="") + if (interactive()) { + packageStartupMessage( + paste( + "\n\033[44m\033[37m", + "\nWelcome to R6P", + "\nMore information, vignettes, and guides are available on the R6P project website:", + "\nhttps://tidylab.github.io/R6P/", + "\n\033[39m\033[49m", + sep = "" + ) ) -}#nocov end + } +} # nocov end diff --git a/R6P.Rproj b/R6P.Rproj index 6c495c2..bccf93f 100644 --- a/R6P.Rproj +++ b/R6P.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 1ea654cd-8c89-4fbc-b9cf-a5ad61baf097 RestoreWorkspace: No SaveWorkspace: No diff --git a/README.Rmd b/README.Rmd index 23c353f..30c041d 100644 --- a/README.Rmd +++ b/README.Rmd @@ -18,19 +18,16 @@ editor_options: ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` -# `R6P` +# `R6P` package logo - [![CRAN status](https://www.r-pkg.org/badges/version/R6P)](https://CRAN.R-project.org/package=R6P) -[![R build -status](https://github.com/tidylab/R6P/workflows/R-CMD-check/badge.svg)](https://github.com/tidylab/R6P/actions) -[![codecov](https://codecov.io/gh/tidylab/R6P/branch/master/graph/badge.svg?token=U6FL5N32FL)](https://codecov.io/gh/tidylab/R6P) - +[![Codecov test coverage](https://codecov.io/gh/tidylab/R6P/graph/badge.svg)](https://app.codecov.io/gh/tidylab/R6P) +[![R-CMD-check](https://github.com/tidylab/R6P/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/tidylab/R6P/actions/workflows/R-CMD-check.yaml) ```{r, echo = FALSE, out.width = "100%"} diff --git a/README.md b/README.md index 43fa170..11f7a7e 100644 --- a/README.md +++ b/README.md @@ -1,15 +1,14 @@ -# `R6P` +# `R6P` package logo [![CRAN status](https://www.r-pkg.org/badges/version/R6P)](https://CRAN.R-project.org/package=R6P) -[![R build -status](https://github.com/tidylab/R6P/workflows/R-CMD-check/badge.svg)](https://github.com/tidylab/R6P/actions) -[![codecov](https://codecov.io/gh/tidylab/R6P/branch/master/graph/badge.svg?token=U6FL5N32FL)](https://codecov.io/gh/tidylab/R6P) - +[![Codecov test +coverage](https://codecov.io/gh/tidylab/R6P/graph/badge.svg)](https://app.codecov.io/gh/tidylab/R6P) +[![R-CMD-check](https://github.com/tidylab/R6P/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/tidylab/R6P/actions/workflows/R-CMD-check.yaml) ## Intentions diff --git a/cran-comments.md b/cran-comments.md index b51aeb0..546740e 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,6 +1,9 @@ +## v0.4.0 Fix Notes +* Fixed the check problems shown on + ## v0.2.2 Bug fix -* Include the tibble pacakge in "Imports" +* Include the tibble package in "Imports" ## v0.2.1 Update @@ -18,9 +21,9 @@ * Discard examples from changing the global environment ## Test environments -* windows (on github-actions), R 4.0.3 -* ubuntu 18.04.5 (on github-actions), R 4.0.3 -* macOS 10.15.7 (on github-actions), R 4.0.3 +* windows (on github-actions), R 4.4.2 +* ubuntu 18.04.5 (on github-actions), R 4.4.2 +* macOS 10.15.7 (on github-actions), R 4.4.2 ## R CMD check results diff --git a/docker-compose.yml b/docker-compose.yml deleted file mode 100644 index aa2d3d2..0000000 --- a/docker-compose.yml +++ /dev/null @@ -1,14 +0,0 @@ -services: - ###################################################### - # R Testing - ###################################################### - r-test: - image: r-package/r6p - build: - context: ./ - dockerfile: ./.dev/docker/r-test/Dockerfile - entrypoint: '/bin/bash' - container_name: r_test - restart: "no" - ###################################################### -version: "3.8" diff --git a/inst/snippets/submitting-package.R b/inst/snippets/submitting-package.R deleted file mode 100644 index 0e4317c..0000000 --- a/inst/snippets/submitting-package.R +++ /dev/null @@ -1,11 +0,0 @@ -devtools::check(remote = TRUE, manual = TRUE) - -rhub::check( platform="windows-x86_64-devel", env_vars=c(R_COMPILE_AND_INSTALL_PACKAGES = "always") ) - -devtools::check_win_devel() - -devtools::build_manual() - -devtools::spell_check() - -utils::maintainer(pkgload::pkg_name()) diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index bab2bd5..4b07fc9 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -5,15 +5,23 @@ authors: href: https://github.com/harell Tidylab: href: "https://github.com/tidylab" - html: "" + html: "TidyLab Homepage" + aria-label: Tidylab Logo + template: + bootstrap: 5 params: docsearch: api_key: d5f049d51d6123dd767e5f8bc7882c35 index_name: tidylab-r6p + # Articles ---------------------------------------------------------------- articles: +- title: internal + contents: + - appendices/Dictionary + - appendices/SpecialCase - title: Base Patterns contents: - patterns/Singleton diff --git a/tests/testthat/helpers-xyz.R b/tests/testthat/helpers-xyz.R index f47b4d2..10f2038 100644 --- a/tests/testthat/helpers-xyz.R +++ b/tests/testthat/helpers-xyz.R @@ -6,18 +6,25 @@ banner <- function(title) paste0(line_break(), paste0("\n## ", title), line_brea # testthat ---------------------------------------------------------------- expect_class <- function(object, class) testthat::expect(any(base::class(object) %in% class), "object is" %+% base::class(object) %+% "not" %+% class) -expect_not_failure <- purrr::partial(testthat::expect_type, type = "environment") expect_has_columns <- function(data, cols) testthat::expect(all(cols %in% colnames(data)), "not all column names are in the data.frame") expect_file_exists <- function(path) testthat::expect(file.exists(path), "File doesn't exist at " %+% path) expect_match <- function(object, regexp) testthat::expect_match(stringr::str_flatten(object, collapse = "\n"), regexp) - +expect_not_failure <- function(object, ...) { + testthat::expect_type(object, type = "environment", ...) +} # mocks ------------------------------------------------------------------- DummyRepository <- R6::R6Class(classname = "Repository", inherit = AbstractRepository, public = list( - initialize = function() private$cars <- collections::dict(), - add = function(key, value){private$cars$set(key, value); return(self)}, - del = function(key){private$cars$remove(key); return(self)}, - get = function(key){return(private$cars$get(key, default = NULL))} + initialize = function() private$cars <- collections::dict(), + add = function(key, value) { + private$cars$set(key, value) + return(self) + }, + del = function(key) { + private$cars$remove(key) + return(self) + }, + get = function(key) { + return(private$cars$get(key, default = NULL)) + } ), private = list(cars = NULL)) - - diff --git a/tests/testthat/test-base-Singleton.R b/tests/testthat/test-base-Singleton.R index 6570204..431e5e6 100644 --- a/tests/testthat/test-base-Singleton.R +++ b/tests/testthat/test-base-Singleton.R @@ -1,45 +1,53 @@ # General ----------------------------------------------------------------- test_that("calling Singleton$new fails because it cannot be instantiated directly", { - expect_error(Singleton$new()) + expect_error(Singleton$new()) }) # Implementation ---------------------------------------------------------- test_that("instantiating of multiple objects of the same Singleton are identical", { - Counter <- R6::R6Class(classname = "Counter", inherit = Singleton, public = list( - count = 0, - add_1 = function(){self$count = self$count + 1; invisible(self)} - )) - - expect_s3_class(counter_1 <- Counter$new(), "Singleton") - expect_s3_class(counter_2 <- Counter$new(), "Counter") - expect_identical(counter_1, counter_2) - - counter_1$add_1() - expect_equal(counter_1$count, counter_2$count) + Counter <- R6::R6Class(classname = "Counter", inherit = Singleton, public = list( + count = 0, + add_1 = function() { + self$count <- self$count + 1 + invisible(self) + } + )) + + expect_s3_class(counter_1 <- Counter$new(), "Singleton") + expect_s3_class(counter_2 <- Counter$new(), "Counter") + expect_identical(counter_1, counter_2) + + counter_1$add_1() + expect_equal(counter_1$count, counter_2$count) }) test_that("instantiating of multiple objects of the same Singleton with superclass", { - SuperCounter <- R6::R6Class(classname = "SuperCounter", inherit = Singleton, public = list( - count = 0, - add_1 = function(){self$count = self$count + 1; invisible(self)}, - initialize = function(){super$initialize()} - )) - - expect_s3_class(counter_1 <- SuperCounter$new(), "Singleton") - expect_s3_class(counter_2 <- SuperCounter$new(), "SuperCounter") - expect_identical(counter_1, counter_2) - - counter_1$add_1() - expect_equal(counter_1$count, counter_2$count) + SuperCounter <- R6::R6Class(classname = "SuperCounter", inherit = Singleton, public = list( + count = 0, + add_1 = function() { + self$count <- self$count + 1 + invisible(self) + }, + initialize = function() { + super$initialize() + } + )) + + expect_s3_class(counter_1 <- SuperCounter$new(), "Singleton") + expect_s3_class(counter_2 <- SuperCounter$new(), "SuperCounter") + expect_identical(counter_1, counter_2) + + counter_1$add_1() + expect_equal(counter_1$count, counter_2$count) }) test_that("instantiating of multiple objects of the different Singleton are not identical", { - SingletonA <- R6::R6Class(classname = "SingletonA", inherit = Singleton, public = list(uid = "A")) - SingletonB <- R6::R6Class(classname = "SingletonB", inherit = Singleton, public = list(uid = "B")) + SingletonA <- R6::R6Class(classname = "SingletonA", inherit = Singleton, public = list(uid = "A")) + SingletonB <- R6::R6Class(classname = "SingletonB", inherit = Singleton, public = list(uid = "B")) - expect_s3_class(singleton_A <- SingletonA$new(), "Singleton") - expect_s3_class(singleton_B <- SingletonB$new(), "Singleton") - expect_false(identical(singleton_A, singleton_B)) + expect_s3_class(singleton_A <- SingletonA$new(), "Singleton") + expect_s3_class(singleton_B <- SingletonB$new(), "Singleton") + expect_false(identical(singleton_A, singleton_B)) }) # test_that("inheriting Singleton takes the last class name", { @@ -51,5 +59,3 @@ test_that("instantiating of multiple objects of the different Singleton are not # # expect_false(identical(level1, level2)) # }) - - diff --git a/tests/testthat/test-object_relational-Repository.R b/tests/testthat/test-object_relational-Repository.R index bad1444..82ed2a7 100644 --- a/tests/testthat/test-object_relational-Repository.R +++ b/tests/testthat/test-object_relational-Repository.R @@ -1,14 +1,14 @@ # General ----------------------------------------------------------------- test_that("calling AbstractRepository$new fails because it cannot be instantiated directly", { - expect_error(AbstractRepository$new()) - expect_named(AbstractRepository$public_methods, c('initialize', 'add', 'del', 'get')) + expect_error(AbstractRepository$new()) + expect_named(AbstractRepository$public_methods, c("initialize", "add", "del", "get")) }) # Implementation ---------------------------------------------------------- test_that("implementing AbstractRepository returns Repository", { - expect_s3_class(repository <- DummyRepository$new(), "Repository") - expect_s3_class(repository$add(key = rownames(mtcars[1,]), value = mtcars[1,]), "Repository") - expect_identical(repository$get(key = rownames(mtcars[1,])), mtcars[1,]) - expect_s3_class(repository$del(key = rownames(mtcars[1,])), "Repository") - expect_null(repository$get(key = rownames(mtcars[1,])), "Repository") + expect_s3_class(repository <- DummyRepository$new(), "Repository") + expect_s3_class(repository$add(key = rownames(mtcars[1, ]), value = mtcars[1, ]), "Repository") + expect_identical(repository$get(key = rownames(mtcars[1, ])), mtcars[1, ]) + expect_s3_class(repository$del(key = rownames(mtcars[1, ])), "Repository") + expect_null(repository$get(key = rownames(mtcars[1, ])), "Repository") }) diff --git a/vignettes/article_template.Rmd b/vignettes/_article_template.Rmd similarity index 86% rename from vignettes/article_template.Rmd rename to vignettes/_article_template.Rmd index ad00b8f..4a3a950 100644 --- a/vignettes/article_template.Rmd +++ b/vignettes/_article_template.Rmd @@ -1,55 +1,55 @@ ---- -title: "Article Template" -bibliography: [../inst/REFERENCES.bib] -biblio-style: apalike -link-citations: yes -nocite: | - @Gamma1995 - @Fowler2002 -editor_options: - markdown: - wrap: 80 ---- - -```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) -``` - - - -Mediates between the domain and data mapping layers using a collection-like -interface for accessing domain objects. - - - - - -## How It Works - -text - -## When to Use It - -text - -## Example: Name of Example 1 - -text - -## Example: Name of Example 2 - -text - -## Further Reading - -```{r, message=TRUE} -message("Signifies a tip or suggestion") -``` - -```{r, warning=TRUE} -warning("Signifies a general note") -``` - -```{r, error=TRUE} -stop("Signifies a warning or caution") -``` +--- +title: "Article Template" +bibliography: [../inst/REFERENCES.bib] +biblio-style: apalike +link-citations: yes +nocite: | + @Gamma1995 + @Fowler2002 +editor_options: + markdown: + wrap: 80 +--- + +```{r, include = FALSE} +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +``` + + + +Mediates between the domain and data mapping layers using a collection-like +interface for accessing domain objects. + + + + + +## How It Works + +text + +## When to Use It + +text + +## Example: Name of Example 1 + +text + +## Example: Name of Example 2 + +text + +## Further Reading + +```{r, message=TRUE} +message("Signifies a tip or suggestion") +``` + +```{r, warning=TRUE} +warning("Signifies a general note") +``` + +```{r, error=TRUE} +stop("Signifies a warning or caution") +``` diff --git a/vignettes/_common.R b/vignettes/_common.R index d9b2c92..868fbbe 100644 --- a/vignettes/_common.R +++ b/vignettes/_common.R @@ -36,16 +36,16 @@ knitr::opts_chunk$set( knitr::knit_hooks$set( error = function(x, options) { paste('\n\n
', - x %>% - stringr::str_replace_all('^.*:', '**Caution:**') %>% + x |> + stringr::str_replace_all('^.*:', '**Caution:**') |> stringr::str_replace_all('#> ', '\n'), '
', sep = '\n') }, warning = function(x, options) { paste('\n\n
', - x %>% - stringr::str_replace_all('##', '\n') %>% - stringr::str_replace_all('^#>\ Warning:', '**Note:**') %>% + x |> + stringr::str_replace_all('##', '\n') |> + stringr::str_replace_all('^#>\ Warning:', '**Note:**') |> stringr::str_remove_all("#>"), '
', sep = '\n') }, diff --git a/vignettes/appendices/Dictionary.Rmd b/vignettes/appendices/Dictionary.Rmd index 38dfce1..e3fa39a 100644 --- a/vignettes/appendices/Dictionary.Rmd +++ b/vignettes/appendices/Dictionary.Rmd @@ -9,7 +9,7 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` `collections::dict` diff --git a/vignettes/appendices/SpecialCase.Rmd b/vignettes/appendices/SpecialCase.Rmd index 179102a..0b85b95 100644 --- a/vignettes/appendices/SpecialCase.Rmd +++ b/vignettes/appendices/SpecialCase.Rmd @@ -9,7 +9,7 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` The NULL object [@Fowler2002, p. 496] diff --git a/vignettes/details/NullObject.Rmd b/vignettes/details/_NullObject.Rmd similarity index 64% rename from vignettes/details/NullObject.Rmd rename to vignettes/details/_NullObject.Rmd index 03d8052..c63378c 100644 --- a/vignettes/details/NullObject.Rmd +++ b/vignettes/details/_NullObject.Rmd @@ -1,105 +1,112 @@ ---- -title: "The Null Object Pattern" -editor_options: - markdown: - wrap: 80 ---- - -```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) -``` - -```{r, error=TRUE} -events$stop_not_useful("NullObject") -``` - - - -***Null Object*** provides special behaviour for particular cases. - -```{r warning=TRUE} -warning("The Null Object is not the same as the reserved word in R `NULL` (all caps).") -``` - -## How It Works - -When a function fails in R, some functions produce a run-time error while others -return `NULL` (and potentially prompt a warning). What the function evokes in -case of a failure is subjected to its programmer discretion. Usually, the -programmer follows either a punitive or forgiving policy regarding how -run-time errors should be handled. - -In other occasions, `NULL` is often the result of unavailable data. This could -happened when querying a data source matches no entries, or when the system is -waiting for user input (mainly in Shiny). - -If it is possible for a function to return `NULL` rather than an error, -then it is important to surround it with null test code, e.g. -`if(is.null(...)) do_the_right_thing()`. This way the software would do the -right thing if a null is present. - -Often the right thing is the same in many contexts, so you end up writing -similar code in lots of places—committing the sin of code duplication. - -Instead of returning `NULL`, or some odd value such as `NaN` or `logical(0)`, return a **Null Object** that has the same interface as what the caller expects. In R, this often means returning a `data.frame` structure, i.e. column names and variables types, with no rows. - - -## When to Use It - -- In situations when a subroutine is likely to fail, such as loss of Internet - or database connectivity. Instead of prompting a run-time error, you could - return the **Null Object** as part of a [gracefully - failing](https://en.wikipedia.org/wiki/Graceful_exit) strategy. A common - strategy employs `tryCatch` that returns the **Null Object** in the case of - an error: - -```{r, echo = TRUE, eval = TRUE} -# Simulate a database that is 5% likely to fail -read_mtcars <- function() if(runif(1) < 0.05) stop() else return(mtcars) - -# mtcars null object constructor -NullCar <- function() mtcars[0,] - -# How does the null car object look like? -NullCar() - -# Subroutine with gracefully failing strategy -set.seed(1814) -cars <- tryCatch( - # Try reading the mtcars dataset - read_mtcars(), - # If there is an error, return the Null Car object - error = function(e) return(NullCar()) -) - -# Notice: Whether the subroutine fails or succeeds, it returns a tibble with -# the same structure. -colnames(cars) -``` - -- In Shiny dashboards - -```{r, echo = TRUE, eval = FALSE} -geom_null <- function(...){ - ggplot2::ggplot() + ggplot2::geom_blank() + ggplot2::theme_void() -} - -if(exists("user_input")){ - ggplot2::ggplot(user_input, ggplot::aes(x = mpg, y = hp)) + ggplot2::geom_point() -} else { - geom_null() + geom_text(aes(0,0), label = "choose an entry from the list") -} -``` - -- In unit-tests - -```{r, echo = TRUE, eval = FALSE} -classes <- function(x) sapply(x, class) - -test_that("mtcars follows a certain table structure", { - # Compare column names - expect_identical(colnames(mtcars), colnames(NullCar())) - # Compare variable types - expect_identical(classes(mtcars), classes(NullCar())) -}) -``` +--- +title: "The Null Object Pattern" +editor_options: + markdown: + wrap: 80 +--- + +```{r, include = FALSE} +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +``` + +```{r, error=TRUE} +events$stop_not_useful("NullObject") +``` + + + +***Null Object*** provides special behaviour for particular cases. + +```{r warning=TRUE} +warning("The Null Object is not the same as the reserved word in R `NULL` (all caps).") +``` + +## How It Works + +When a function fails in R, some functions produce a run-time error while others +return `NULL` (and potentially prompt a warning). What the function evokes in +case of a failure is subjected to its programmer discretion. Usually, the +programmer follows either a punitive or forgiving policy regarding how run-time +errors should be handled. + +In other occasions, `NULL` is often the result of unavailable data. This could +happened when querying a data source matches no entries, or when the system is +waiting for user input (mainly in Shiny). + +If it is possible for a function to return `NULL` rather than an error, then it +is important to surround it with null test code, e.g. +`if(is.null(...)) do_the_right_thing()`. This way the software would do the +right thing if a null is present. + +Often the right thing is the same in many contexts, so you end up writing +similar code in lots of places—committing the sin of code duplication. + +Instead of returning `NULL`, or some odd value such as `NaN` or `logical(0)`, +return a **Null Object** that has the same interface as what the caller expects. +In R, this often means returning a `data.frame` structure, i.e. column names and +variables types, with no rows. + +## When to Use It + +- In situations when a subroutine is likely to fail, such as loss of Internet + or database connectivity. Instead of prompting a run-time error, you could + return the **Null Object** as part of a [gracefully + failing](https://en.wikipedia.org/wiki/Graceful_exit) strategy. A common + strategy employs `tryCatch` that returns the **Null Object** in the case of + an error: + +```{r, echo = TRUE, eval = TRUE} +# Simulate a database that is 5% likely to fail +read_mtcars <- function() if (runif(1) < 0.05) stop() else return(mtcars) + +# mtcars null object constructor +NullCar <- function() mtcars[0, ] + +# How does the null car object look like? +NullCar() + +# Subroutine with gracefully failing strategy +set.seed(1814) +cars <- tryCatch( + # Try reading the mtcars dataset + read_mtcars(), + # If there is an error, return the Null Car object + error = function(e) { + return(NullCar()) + } +) + +# Notice: Whether the subroutine fails or succeeds, it returns a tibble with +# the same structure. +colnames(cars) +``` + +- In Shiny dashboards + +```{r, echo = TRUE, eval = FALSE} +geom_null <- function(...) { + ggplot2::ggplot() + + ggplot2::geom_blank() + + ggplot2::theme_void() +} + +if (exists("user_input")) { + ggplot2::ggplot(user_input, ggplot::aes(x = mpg, y = hp)) + + ggplot2::geom_point() +} else { + geom_null() + geom_text(aes(0, 0), label = "choose an entry from the list") +} +``` + +- In unit-tests + +```{r, echo = TRUE, eval = FALSE} +classes <- function(x) sapply(x, class) + +test_that("mtcars follows a certain table structure", { + # Compare column names + expect_identical(colnames(mtcars), colnames(NullCar())) + # Compare variable types + expect_identical(classes(mtcars), classes(NullCar())) +}) +``` diff --git a/vignettes/details/Repository.Rmd b/vignettes/details/_Repository.Rmd similarity index 94% rename from vignettes/details/Repository.Rmd rename to vignettes/details/_Repository.Rmd index 769dcaf..0af6c95 100644 --- a/vignettes/details/Repository.Rmd +++ b/vignettes/details/_Repository.Rmd @@ -1,52 +1,52 @@ ---- -title: "The Repository Pattern" -editor_options: - markdown: - wrap: 80 ---- - -```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) -``` - - - -With ***Repository***, in-memory objects do not need to know whether there is a -database present or absent, they need no SQL interface code, and certainly no -knowledge of the database schema. - -## How It Works - -- **Repository** isolates domain objects from details of the database access - code; -- **Repository** concentrates code of query construction; and -- **Repository** helps to minimize duplicate query logic. - -In R, the simplest form of **Repository** encapsulates `data.frame` entries -persisted in a data store and the operations performed over them, providing a -more object-oriented view of the persistence layer. From the caller point of -view, the location (locally or remotely), the technology and the interface of -the data store are obscured. - -## When to Use It - -- In situations with multiple data sources. - -- In situations where the real data store, the one that is used in production, - is remote. This allows you to implement a **Repository** mock with identical - queries that runs locally. Then, the mock could be used during development - and testing. The mock itself may comprise a sample of the real data store or - just fake data. - -- In situations where the real data store doesn't exist. Implementing a mock - **Repository** allows you to defer immature decisions about the database - technology and/or defer its deployment. In this way, the temporary solution - allows you to focus the development effort on the core functionality of the - application. - -- In situations where using SQL queries can be represented by meaningful - names. For example - `Repository$get_efficient_cars() = SELECT * FROM mtcars WHERE mpg > 20` - -- When building [stateless - microservices](https://www.oreilly.com/library/view/software-architects-handbook/9781788624060/c47a09b6-91f9-4322-a6d4-9bc1604b1bdf.xhtml). +--- +title: "The Repository Pattern" +editor_options: + markdown: + wrap: 80 +--- + +```{r, include = FALSE} +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +``` + + + +With ***Repository***, in-memory objects do not need to know whether there is a +database present or absent, they need no SQL interface code, and certainly no +knowledge of the database schema. + +## How It Works + +- **Repository** isolates domain objects from details of the database access + code; +- **Repository** concentrates code of query construction; and +- **Repository** helps to minimize duplicate query logic. + +In R, the simplest form of **Repository** encapsulates `data.frame` entries +persisted in a data store and the operations performed over them, providing a +more object-oriented view of the persistence layer. From the caller point of +view, the location (locally or remotely), the technology and the interface of +the data store are obscured. + +## When to Use It + +- In situations with multiple data sources. + +- In situations where the real data store, the one that is used in production, + is remote. This allows you to implement a **Repository** mock with identical + queries that runs locally. Then, the mock could be used during development + and testing. The mock itself may comprise a sample of the real data store or + just fake data. + +- In situations where the real data store doesn't exist. Implementing a mock + **Repository** allows you to defer immature decisions about the database + technology and/or defer its deployment. In this way, the temporary solution + allows you to focus the development effort on the core functionality of the + application. + +- In situations where using SQL queries can be represented by meaningful + names. For example + `Repository$get_efficient_cars() = SELECT * FROM mtcars WHERE mpg > 20` + +- When building [stateless + microservices](https://www.oreilly.com/library/view/software-architects-handbook/9781788624060/c47a09b6-91f9-4322-a6d4-9bc1604b1bdf.xhtml). diff --git a/vignettes/details/Singleton.Rmd b/vignettes/details/_Singleton.Rmd similarity index 91% rename from vignettes/details/Singleton.Rmd rename to vignettes/details/_Singleton.Rmd index 82a5b60..6d90ada 100644 --- a/vignettes/details/Singleton.Rmd +++ b/vignettes/details/_Singleton.Rmd @@ -1,43 +1,42 @@ ---- -title: "The Singleton Pattern" -editor_options: - markdown: - wrap: 80 ---- - -```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) -``` - - - -***Singleton*** ensures a class only has one instance, and provide a global -point of access to it. - -## How It Works - -1. Create only one instance of the **Singleton** class; and -2. If an instance exists, then serve the same object again. - -The main features of **Singleton** are: - -- Ensuring that one and only one object of the class gets created; - -- Providing an access point for an object that is global to the program; and - -- Controlling concurrent access to resources that are shared. - -## When to Use It - -- In situations that require exactly one instance of a class, that must be - accessible to clients from a well-known access point. See the [`Counter` - example](#example-1). - -```{r, error=TRUE} -stop("Singletons can be a problem in multi-threaded applications, especially when they manipulate mutable data.") -``` - -```{r, message=TRUE} -message("Singletons work well for immutable data, such as reading from some data source, since anything that can’t change isn’t going to run into thread clash problems.") -``` - +--- +title: "The Singleton Pattern" +editor_options: + markdown: + wrap: 80 +--- + +```{r, include = FALSE} +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +``` + + + +***Singleton*** ensures a class only has one instance, and provide a global +point of access to it. + +## How It Works + +1. Create only one instance of the **Singleton** class; and +2. If an instance exists, then serve the same object again. + +The main features of **Singleton** are: + +- Ensuring that one and only one object of the class gets created; + +- Providing an access point for an object that is global to the program; and + +- Controlling concurrent access to resources that are shared. + +## When to Use It + +- In situations that require exactly one instance of a class, that must be + accessible to clients from a well-known access point. See the [`Counter` + example](#example-1). + +```{r, error=TRUE} +stop("Singletons can be a problem in multi-threaded applications, especially when they manipulate mutable data.") +``` + +```{r, message=TRUE} +message("Singletons work well for immutable data, such as reading from some data source, since anything that can’t change isn’t going to run into thread clash problems.") +``` diff --git a/vignettes/details/ValueObject.Rmd b/vignettes/details/_ValueObject.Rmd similarity index 91% rename from vignettes/details/ValueObject.Rmd rename to vignettes/details/_ValueObject.Rmd index ef22964..f708385 100644 --- a/vignettes/details/ValueObject.Rmd +++ b/vignettes/details/_ValueObject.Rmd @@ -1,197 +1,199 @@ ---- -title: "The Value Object Pattern" -editor_options: - markdown: - wrap: 80 ---- - -```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) -NA_POSIXct_ <- .POSIXct(NA_real_, tz = "UTC") -is.POSIXct <- function(x) inherits(x, "POSIXct") -``` - -```{r, error=TRUE} -events$stop_not_useful("ValueObject") -``` - - - -A **Value Object** models a domain concept using natural lingo of the domain -experts, such as "Passenger", "Address", and "Money". - -Any **Value Object** is created by a function that receives input, applies some -transformations, and outputs the results in some data structure such as a -vector, a list or a data.frame. - -## How It Works - -In R, a good option for creating a **Value Object** is to follow two -instructions: - -- A **Value Object** is created by a `function`, rather than a class method; - and -- A **Value Object** returns a `tibble`, rather than a list or a vector. - -In essence, a **Value Object** is a data type, like `integer`, `logical`, `Date` -or `data.frame` data types to name a few. While the built-in data types in R fit -any application, **Value Objects** are domain specific and as such, they fit -only to a specific application. This is because, `integer` is an abstract that -represent whole numbers. This abstract is useful in any application. However, a -**Value Object** represent a high-level abstraction that appears in a particular -domain. - -An example of a **Value Object** is the notion of a "Person". Any person in the -world has a name. Needless to say, a person name is spelt by letters, rather -than numbers. A **Value Object** captures these attribute as `tibble` columns -and type checks: - -```{r, echo=TRUE} -Person <- function(given = NA_character_, family = NA_character_){ - stopifnot(is.character(given), is.character(family)) - stopifnot(length(given) == length(family)) - - return( - tibble::tibble(given = given, family = family) - %>% tidyr::drop_na(given) - ) -} -``` - -Instantiating a person **Value Object** is done by calling the `Person` -constructor function: - -```{r, echo=TRUE} -person <- Person(given = "Bilbo", family = "Baggins") -``` - -Getting to know the advantages of a **Value Object**, we should consider the -typical alternative -- constructing a Person by using the `tibble` function -directly: - -```{r, echo=TRUE} -person <- tibble::tibble(given = "Bilbo", family = "Baggins") -``` - -Both implementations return objects with identical content and structure, that -is, their column names, column types and cell values are identical. Then, why -would one prefer using a **Value Object** and its constructor over the direct -alternative? - -There are four predominant qualities offered by the **Value Object** pattern -which are not offered by the alternative: - -1. Readability. Each **Value Object** captures a concept belonging to the - problem domain. Rather than trying to infer what a `tibble` is by looking at - its low-level details, the **Value Object** constructor descries a context - on a high-level. - -2. Explicitness. Since the constructor of the **Value Object** is a function, - its expected input arguments and their type can be detailed in a helper - file. Moreover, assigning input arguments with default values of specific - type, such as `NA` (logical NA), `NA_integer_`, `NA_character_`, or - `NA_Date` (see `lubridate::NA_Date`), expresses clearly the variable types - of the **Value Object**. - -3. Coherence. The representation of a **Value Object** is concentrated in one - place -- its constructor. Any change, mainly modifications and extensions, - applied to the constructor promise the change would propagate to all - instances of the Value Objects. That means, no structure discrepancies - between instances that are supposed to represent the same concept. - -4. Safety. The constructor may start with [defensive - programming](https://en.wikipedia.org/wiki/Defensive_programming) to ensure - the qualities of its input. One important assertion is type checking. Type - checking eliminated the risk of implicit type coercing. Another important - assertion is checking if the lengths of the input arguments meet some - criteria, say all inputs are of the same length, or more restrictively, all - inputs are scalars. Having a set of checks makes the code base more robust. - This is because **Value Objects** are regularly created with the output of - other functions calls, having a set of checks serves as pseudo-tests of - these functions output throughout the code. - -In addition to these qualities, there are two desirable behaviours which are not -offered by directly calling `tibble`: - -1. Null Value Object. Calling the **Value Object** constructor with no input - arguments returns the structure of the `tibble` (column names and column - types). - -2. Default values for missing input arguments. In this manner, the **Value - Object** has a well-defined behaviour for a person without a family name, - such as Madonna and Bono. - -In addition to native R data types, a **Value Object** constructor can receive -other **Value Objects** as input arguments. Here are two examples that transmute -Person to other Person-based concepts: - -```{r, echo = TRUE, eval = TRUE} -# A Passenger is a Person with a flight booking reference -Passenger <- function(person = Person(), booking_reference = NA_character_){ - stopifnot(all(colnames(person) %in% colnames(Person()))) - stopifnot(is.character(booking_reference)) - - return( - person - %>% tibble::add_column(booking_reference = booking_reference) - %>% tidyr::drop_na(booking_reference) - ) -} - -person <- Person(given = "Bilbo", family = "Baggins") -passenger <- Passenger(person = person, booking_reference = "B662HR") -print(passenger) -``` - -```{r, echo = TRUE, eval = TRUE} -# A Diner is a Person that may have dinner reservation -Diner <- function(person = Person(), reservation_time = NA_POSIXct_){ - stopifnot(all(colnames(person) %in% colnames(Person()))) - stopifnot(is.POSIXct(reservation_time)) - - return( - person - %>% tibble::add_column(reservation_time = reservation_time) - ) -} - -person <- Person(given = "Bilbo", family = "Baggins") -timestamp <- as.POSIXct("2021-01-23 18:00:00 NZDT") -diner <- Diner(person = person, reservation_time = timestamp) -print(diner) -``` - -## When to Use It - -- In situations where domain concepts are more important then the database - schema. For example, when you are modelling Passengers, your first instinct - might be to think about the different data sources you'd need for the - analysis. You may envision "FlightDetails" and "CustomerDetails". Next you - will define the relationship between them. Instead, let the domain drive the - design. Create a Passenger **Value Object** with the attributes you must - have, regardless of any particular database schema. - -- In a function that runs within a specific context. Rather than having an - input argument called `data` of type `data.frame`, use the appropriate - **Value Object** name and pass it its constructor. - -```{r, echo = TRUE, eval = FALSE} -Audience <- Person - -## Without a Value Object -clean_audience_data <- function(data) - dplyr::mutate(.data = data, given = stringr::str_to_title(given)) - -## With a Value Object -clean_audience_data <- function(attendees = Audience()) - dplyr::mutate(.data = attendees, given = stringr::str_to_title(given)) -``` - -- In [pipes and filters](https://en.wikipedia.org/wiki/Pipeline_(software)) - architecture. - -```{r, warning=TRUE} -warning("**Value Objects** do not need to have unit-tests. This is because of two reasons: -(1) **Value Objects** are often called by other functions that are being tested. That means, **Value Objects** are implicitly tested. -(2) **Value Objects** are data types similarly to 'data.frame' or 'list'. As such, they need no testing") -``` +--- +title: "The Value Object Pattern" +editor_options: + markdown: + wrap: 80 +--- + +```{r, include = FALSE} +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +NA_POSIXct_ <- .POSIXct(NA_real_, tz = "UTC") +is.POSIXct <- function(x) inherits(x, "POSIXct") +``` + +```{r, error=TRUE} +events$stop_not_useful("ValueObject") +``` + + + +A **Value Object** models a domain concept using natural lingo of the domain +experts, such as "Passenger", "Address", and "Money". + +Any **Value Object** is created by a function that receives input, applies some +transformations, and outputs the results in some data structure such as a +vector, a list or a data.frame. + +## How It Works + +In R, a good option for creating a **Value Object** is to follow two +instructions: + +- A **Value Object** is created by a `function`, rather than a class method; + and +- A **Value Object** returns a `tibble`, rather than a list or a vector. + +In essence, a **Value Object** is a data type, like `integer`, `logical`, `Date` +or `data.frame` data types to name a few. While the built-in data types in R fit +any application, **Value Objects** are domain specific and as such, they fit +only to a specific application. This is because, `integer` is an abstract that +represent whole numbers. This abstract is useful in any application. However, a +**Value Object** represent a high-level abstraction that appears in a particular +domain. + +An example of a **Value Object** is the notion of a "Person". Any person in the +world has a name. Needless to say, a person name is spelt by letters, rather +than numbers. A **Value Object** captures these attribute as `tibble` columns +and type checks: + +```{r, echo=TRUE} +Person <- function(given = NA_character_, family = NA_character_) { + stopifnot(is.character(given), is.character(family)) + stopifnot(length(given) == length(family)) + + return( + tibble::tibble(given = given, family = family) + |> tidyr::drop_na(given) + ) +} +``` + +Instantiating a person **Value Object** is done by calling the `Person` +constructor function: + +```{r, echo=TRUE} +person <- Person(given = "Bilbo", family = "Baggins") +``` + +Getting to know the advantages of a **Value Object**, we should consider the +typical alternative -- constructing a Person by using the `tibble` function +directly: + +```{r, echo=TRUE} +person <- tibble::tibble(given = "Bilbo", family = "Baggins") +``` + +Both implementations return objects with identical content and structure, that +is, their column names, column types and cell values are identical. Then, why +would one prefer using a **Value Object** and its constructor over the direct +alternative? + +There are four predominant qualities offered by the **Value Object** pattern +which are not offered by the alternative: + +1. Readability. Each **Value Object** captures a concept belonging to the + problem domain. Rather than trying to infer what a `tibble` is by looking at + its low-level details, the **Value Object** constructor descries a context + on a high-level. + +2. Explicitness. Since the constructor of the **Value Object** is a function, + its expected input arguments and their type can be detailed in a helper + file. Moreover, assigning input arguments with default values of specific + type, such as `NA` (logical NA), `NA_integer_`, `NA_character_`, or + `NA_Date` (see `lubridate::NA_Date`), expresses clearly the variable types + of the **Value Object**. + +3. Coherence. The representation of a **Value Object** is concentrated in one + place -- its constructor. Any change, mainly modifications and extensions, + applied to the constructor promise the change would propagate to all + instances of the Value Objects. That means, no structure discrepancies + between instances that are supposed to represent the same concept. + +4. Safety. The constructor may start with [defensive + programming](https://en.wikipedia.org/wiki/Defensive_programming) to ensure + the qualities of its input. One important assertion is type checking. Type + checking eliminated the risk of implicit type coercing. Another important + assertion is checking if the lengths of the input arguments meet some + criteria, say all inputs are of the same length, or more restrictively, all + inputs are scalars. Having a set of checks makes the code base more robust. + This is because **Value Objects** are regularly created with the output of + other functions calls, having a set of checks serves as pseudo-tests of + these functions output throughout the code. + +In addition to these qualities, there are two desirable behaviours which are not +offered by directly calling `tibble`: + +1. Null Value Object. Calling the **Value Object** constructor with no input + arguments returns the structure of the `tibble` (column names and column + types). + +2. Default values for missing input arguments. In this manner, the **Value + Object** has a well-defined behaviour for a person without a family name, + such as Madonna and Bono. + +In addition to native R data types, a **Value Object** constructor can receive +other **Value Objects** as input arguments. Here are two examples that transmute +Person to other Person-based concepts: + +```{r, echo = TRUE, eval = TRUE} +# A Passenger is a Person with a flight booking reference +Passenger <- function(person = Person(), booking_reference = NA_character_) { + stopifnot(all(colnames(person) %in% colnames(Person()))) + stopifnot(is.character(booking_reference)) + + return( + person + |> tibble::add_column(booking_reference = booking_reference) + |> tidyr::drop_na(booking_reference) + ) +} + +person <- Person(given = "Bilbo", family = "Baggins") +passenger <- Passenger(person = person, booking_reference = "B662HR") +print(passenger) +``` + +```{r, echo = TRUE, eval = TRUE} +# A Diner is a Person that may have dinner reservation +Diner <- function(person = Person(), reservation_time = NA_POSIXct_) { + stopifnot(all(colnames(person) %in% colnames(Person()))) + stopifnot(is.POSIXct(reservation_time)) + + return( + person + |> tibble::add_column(reservation_time = reservation_time) + ) +} + +person <- Person(given = "Bilbo", family = "Baggins") +timestamp <- as.POSIXct("2021-01-23 18:00:00 NZDT") +diner <- Diner(person = person, reservation_time = timestamp) +print(diner) +``` + +## When to Use It + +- In situations where domain concepts are more important then the database + schema. For example, when you are modelling Passengers, your first instinct + might be to think about the different data sources you'd need for the + analysis. You may envision "FlightDetails" and "CustomerDetails". Next you + will define the relationship between them. Instead, let the domain drive the + design. Create a Passenger **Value Object** with the attributes you must + have, regardless of any particular database schema. + +- In a function that runs within a specific context. Rather than having an + input argument called `data` of type `data.frame`, use the appropriate + **Value Object** name and pass it its constructor. + +```{r, echo = TRUE, eval = FALSE} +Audience <- Person + +## Without a Value Object +clean_audience_data <- function(data) { + dplyr::mutate(.data = data, given = stringr::str_to_title(given)) +} + +## With a Value Object +clean_audience_data <- function(attendees = Audience()) { + dplyr::mutate(.data = attendees, given = stringr::str_to_title(given)) +} +``` + +- In [pipes and filters](https://en.wikipedia.org/wiki/Pipeline_(software)) + architecture. + +```{r, warning=TRUE} +warning("**Value Objects** do not need to have unit-tests. This is because of two reasons: +(1) **Value Objects** are often called by other functions that are being tested. That means, **Value Objects** are implicitly tested. +(2) **Value Objects** are data types similarly to 'data.frame' or 'list'. As such, they need no testing") +``` diff --git a/vignettes/patterns/NullObject.Rmd b/vignettes/patterns/NullObject.Rmd index 0ea8e0a..57d9eea 100644 --- a/vignettes/patterns/NullObject.Rmd +++ b/vignettes/patterns/NullObject.Rmd @@ -11,70 +11,77 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` -```{r child="../details/NullObject.Rmd"} +```{r, echo=FALSE, results='asis'} +cat(knitr::knit_child('./vignettes/details/_NullObject.Rmd', quiet = TRUE)) ``` ## Example: Null ggplot2 - ```{r, echo=TRUE, eval=FALSE} -geom_null <- function(...){ - ggplot2::ggplot() + ggplot2::geom_blank() + ggplot2::theme_void() +geom_null <- function(...) { + ggplot2::ggplot() + + ggplot2::geom_blank() + + ggplot2::theme_void() } ``` -* Useful as part of a [gracefully failing](https://en.wikipedia.org/wiki/Graceful_exit) strategy. +- Useful as part of a [gracefully + failing](https://en.wikipedia.org/wiki/Graceful_exit) strategy. ```{r, echo=TRUE, eval=FALSE} -fig <- - tryCatch({ - stopifnot(runif(1) > 0.05) # simulate 5% chance for the subroutine to fail - - mtcars %>% - ggplot2::ggplot(ggplot::aes(x = mpg, y = hp)) + - ggplot2::geom_point() - }, - error = function(e) return(geom_null()) # if subroutine has failed, return null +fig <- + tryCatch( + { + stopifnot(runif(1) > 0.05) # simulate 5% chance for the subroutine to fail + + mtcars |> + ggplot2::ggplot(ggplot::aes(x = mpg, y = hp)) + + ggplot2::geom_point() + }, + error = function(e) { + return(geom_null()) + } # if subroutine has failed, return null ) plot(fig) ``` -* Useful in shiny dashboards when a visual is dependent on the user selection of -what to plot. In this case, you could also add a "call to action" text as a -ggplot object. +- Useful in shiny dashboards when a visual is dependent on the user selection + of what to plot. In this case, you could also add a "call to action" text as + a ggplot object. ```{r, echo=TRUE, eval=FALSE} -if(exists("user_input")){ - ggplot2::ggplot(user_input, ggplot::aes(x = mpg, y = hp)) + ggplot2::geom_point() +if (exists("user_input")) { + ggplot2::ggplot(user_input, ggplot::aes(x = mpg, y = hp)) + + ggplot2::geom_point() } else { - geom_null() + geom_text(aes(0,0), label = "choose an entry from the list") + geom_null() + geom_text(aes(0, 0), label = "choose an entry from the list") } ``` ## Example: Null mtcars Car ```{r, echo=TRUE} -NullCar <- function() mtcars[0,] +NullCar <- function() mtcars[0, ] print(NullCar()) # The Null Car and the NULL value are not the same identical(NullCar(), NULL) -# Binding mtcars with the Null Car returns mtcars +# Binding mtcars with the Null Car returns mtcars identical(rbind(mtcars, NullCar()), mtcars) ``` ## Example: Null Value Object ```{r, echo=TRUE} -Person <- function(given = NA_character_, family = NA_character_){ - tibble::tibble(given = given, family = family) %>% tidyr::drop_na(given) +Person <- function(given = NA_character_, family = NA_character_) { + tibble::tibble(given = given, family = family) |> tidyr::drop_na(given) } # Instantiating a person with a `given` name, returns a non-null person object diff --git a/vignettes/patterns/Repository.Rmd b/vignettes/patterns/Repository.Rmd index 9c76167..9de6078 100644 --- a/vignettes/patterns/Repository.Rmd +++ b/vignettes/patterns/Repository.Rmd @@ -11,12 +11,13 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` -```{r child="../details/Repository.Rmd"} +```{r, echo=FALSE, results='asis'} +cat(knitr::knit_child('./vignettes/details/_Repository.Rmd', quiet = TRUE)) ``` ## Implementations @@ -26,7 +27,10 @@ The code of the abstract base class of **Repository** is ```{r} path_snippet <- usethis::proj_path("R", "object_relational-Repository.R") snippet <- readLines(path_snippet) -snippet <- snippet %>% discard_comments() %>% discard_null() %>% discard_empty_lines() +snippet <- snippet |> + discard_comments() |> + discard_null() |> + discard_empty_lines() ``` ```{r, code = snippet, eval = FALSE, echo = TRUE} @@ -36,7 +40,6 @@ snippet <- snippet %>% discard_comments() %>% discard_null() %>% discard_empty_l message("By passing the input argument `inherit = Singleton`, the `AbstractRepository` inherits the qualities of the [**Singleton** pattern](https://tidylab.github.io/R6P/articles/patterns/Singleton.html).") ``` - The given implementing of `AbstractRepository` requires you to define four functions: @@ -84,32 +87,52 @@ message("Transient implementations are a temporal solution that is good for test stop("Transient implementations are not recommended during the production stage. Transient storage is lost when a session is rebooted. You should think about what are the ramifications of losing all the data put into storage.") ``` -First, we define the class constructor, `initialize`, to establish a transient data storage. In this case we use a dictionary from the [`collections` package](https://randy3k.github.io/collections/reference/dict.html). +First, we define the class constructor, `initialize`, to establish a transient +data storage. In this case we use a dictionary from the [`collections` +package](https://randy3k.github.io/collections/reference/dict.html). -Second, we define the `add`, `del` and `get` functions that operate on the dictionary. +Second, we define the `add`, `del` and `get` functions that operate on the +dictionary. -As an optional step, we define the NULL object. In this case, rather then the reserved word `NULL`, the NULL object is a data.frame with 0 rows and predefined column. +As an optional step, we define the NULL object. In this case, rather then the +reserved word `NULL`, the NULL object is a data.frame with 0 rows and predefined +column. ```{r Repository-Transient-implementation, echo=TRUE, results='markup'} TransientRepository <- R6::R6Class( classname = "Repository", inherit = R6P::AbstractRepository, public = list( - initialize = function() {private$cars <- collections::dict()}, - add = function(key, value){private$cars$set(key, value); invisible(self)}, - del = function(key){private$cars$remove(key); invisible(self)}, - get = function(key){return(private$cars$get(key, default = private$NULL_car))} + initialize = function() { + private$cars <- collections::dict() + }, + add = function(key, value) { + private$cars$set(key, value) + invisible(self) + }, + del = function(key) { + private$cars$remove(key) + invisible(self) + }, + get = function(key) { + return(private$cars$get(key, default = private$NULL_car)) + } ), private = list( - NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0,], + NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0, ], cars = NULL - )) + ) +) ``` Adding customised operations is also possible via the R6 `set` function. The following example, adds a query that returns all the objects in the database ```{r Repository-Transient-implementation-addon, echo=TRUE, results='markup'} -TransientRepository$set("public", "get_all_cars", overwrite = TRUE, function(){ - result <- private$cars$values() %>% dplyr::bind_rows() - if(nrow(result) == 0) return(private$NULL_car) else return(result) +TransientRepository$set("public", "get_all_cars", overwrite = TRUE, function() { + result <- private$cars$values() |> dplyr::bind_rows() + if (nrow(result) == 0) { + return(private$NULL_car) + } else { + return(result) + } }) ``` @@ -117,7 +140,7 @@ In this example, we use the `mtcars` dataset with a `uid` column that uniquely identifies the different cars in the **Repository**: ```{r, echo=TRUE, results='markup'} -mtcars <- datasets::mtcars %>% tibble::rownames_to_column("uid") +mtcars <- datasets::mtcars |> tibble::rownames_to_column("uid") head(mtcars, 2) ``` @@ -146,41 +169,50 @@ repository$get(key = "Mazda RX4") ### Example: Persistent Storage Implementation with [`DBI`](https://dbi.r-dbi.org/) -First, we define the class constructor, `initialize`, to establish an SQLite database. +First, we define the class constructor, `initialize`, to establish an SQLite +database. -Second, we define the `add`, `del` and `get` functions that operate on the dictionary. +Second, we define the `add`, `del` and `get` functions that operate on the +dictionary. -As an optional step, we define the NULL object. In this case, rather then the reserved word `NULL`, the NULL object is a data.frame with 0 rows and predefined column. +As an optional step, we define the NULL object. In this case, rather then the +reserved word `NULL`, the NULL object is a data.frame with 0 rows and predefined +column. ```{r Repository-Persistent-implementation, echo=TRUE} PersistentRepository <- R6::R6Class( classname = "Repository", inherit = AbstractRepository, public = list( #' @param immediate (`logical`) Should queries be committed immediately? - initialize = function(immediate = TRUE){ + initialize = function(immediate = TRUE) { private$immediate <- immediate private$conn <- DBI::dbConnect(RSQLite::SQLite(), dbname = ":memory:") DBI::dbCreateTable(private$conn, "mtcars", private$NULL_car) }, - add = function(key, value){ - car <- private$NULL_car %>% tibble::add_row(value) + add = function(key, value) { + car <- private$NULL_car |> tibble::add_row(value) self$del(key = key) DBI::dbAppendTable(private$conn, "mtcars", car) invisible(self) }, - del = function(key){ + del = function(key) { statement <- paste0("DELETE FROM mtcars WHERE uid = '", key, "'") DBI::dbExecute(private$conn, statement, immediate = private$immediate) invisible(self) }, - get = function(key){ + get = function(key) { statement <- paste0("SELECT * FROM mtcars WHERE uid = '", key, "'") result <- DBI::dbGetQuery(private$conn, statement) - if(nrow(result) == 0) return(private$NULL_car) else return(result) + if (nrow(result) == 0) { + return(private$NULL_car) + } else { + return(result) + } } ), private = list( - NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0,], + NULL_car = cbind(uid = NA_character_, datasets::mtcars)[0, ], immediate = NULL, - conn = NULL) + conn = NULL + ) ) ``` @@ -188,10 +220,14 @@ Adding customised operations is also possible via the R6 `set` function. The following example, adds a query that returns all the objects in the database ```{r Repository-Persistent-implementation-addon, echo=TRUE} -PersistentRepository$set("public", "get_all_cars", overwrite = TRUE, function(){ +PersistentRepository$set("public", "get_all_cars", overwrite = TRUE, function() { statement <- "SELECT * FROM mtcars" result <- DBI::dbGetQuery(private$conn, statement) - if(nrow(result) == 0) return(private$NULL_car) else return(result) + if (nrow(result) == 0) { + return(private$NULL_car) + } else { + return(result) + } }) ``` @@ -199,7 +235,7 @@ In this example, we use the `mtcars` dataset with a `uid` column that uniquely identifies the different cars in the **Repository**: ```{r, echo=TRUE, results='markup'} -mtcars <- datasets::mtcars %>% tibble::rownames_to_column("uid") +mtcars <- datasets::mtcars |> tibble::rownames_to_column("uid") head(mtcars, 2) ``` diff --git a/vignettes/patterns/Singleton.Rmd b/vignettes/patterns/Singleton.Rmd index f2e11e0..efbee99 100644 --- a/vignettes/patterns/Singleton.Rmd +++ b/vignettes/patterns/Singleton.Rmd @@ -11,14 +11,16 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` -```{r child="../details/Singleton.Rmd"} +```{r, echo=FALSE, results='asis'} +cat(knitr::knit_child('./vignettes/details/_Singleton.Rmd', quiet = TRUE)) ``` + ## Example: Counter {#example-1} In this example we implement a `Counter` that inherits the qualities of @@ -26,8 +28,11 @@ In this example we implement a `Counter` that inherits the qualities of ```{r Singleton-Counter-implementation, echo=TRUE, results='markup'} Counter <- R6::R6Class(inherit = Singleton, public = list( - count = 0, - add_1 = function(){self$count = self$count + 1; invisible(self)} + count = 0, + add_1 = function() { + self$count <- self$count + 1 + invisible(self) + } )) ``` @@ -56,7 +61,7 @@ counter_A$add_1() # How many times have the counters been increased? counter_A$count -counter_B$count +counter_B$count ``` ## Example: Data Transfer Object (DTO) @@ -69,19 +74,19 @@ Notice how the `initialize` public method first calls the `initialize` of the ```{r Singleton-DTO-implementation, echo=TRUE, results='hold', eval=TRUE} DTO <- R6::R6Class(classname = "DTO", inherit = Singleton, public = list( - con = NULL, - initialize = function(){ - super$initialize() - self$establish_connection() - }, - establish_connection = function(){ - self$con <- DBI::dbConnect(RSQLite::SQLite(), dbname = ":memory:") - return(self) - }, - dbSendQuery = function(statement){ - res <- DBI::dbSendQuery(self$con, statement) - return(res) - } + con = NULL, + initialize = function() { + super$initialize() + self$establish_connection() + }, + establish_connection = function() { + self$con <- DBI::dbConnect(RSQLite::SQLite(), dbname = ":memory:") + return(self) + }, + dbSendQuery = function(statement) { + res <- DBI::dbSendQuery(self$con, statement) + return(res) + } )) ``` diff --git a/vignettes/patterns/ValueObject.Rmd b/vignettes/patterns/ValueObject.Rmd index afd9c0d..8a9537b 100644 --- a/vignettes/patterns/ValueObject.Rmd +++ b/vignettes/patterns/ValueObject.Rmd @@ -11,12 +11,13 @@ editor_options: --- ```{r, include = FALSE} -source(file.path(usethis::proj_get(), "vignettes", "_common.R")) +source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ``` -```{r child="../details/ValueObject.Rmd"} +```{r, echo=FALSE, results='asis'} +cat(knitr::knit_child('./vignettes/details/_ValueObject.Rmd', quiet = TRUE)) ``` @@ -24,32 +25,33 @@ source(file.path(usethis::proj_get(), "vignettes", "_common.R")) ## Example: Person and Minister Value Objects In this example, we are appointing elected officials to random ministries, just -like in real life. +like in real life. The nomination process comprises three components: input, function, output. -* The input is the given and family names of a **Person** -* The function receives a **Person** value object and pairs it with ministry titles -* The output is a **Minister** value object +- The input is the given and family names of a **Person** +- The function receives a **Person** value object and pairs it with ministry + titles +- The output is a **Minister** value object - **Person** -> appoint_random_ministries +**Person** -\> appoint_random_ministries First, we implement the input type. `Person()` is the constructor of the **Person** value object. ```{r, echo=TRUE} #' @title Person Value Object Constructor -#' @description A Person encapsulates the information that constitute an individual +#' @description A Person encapsulates the information that constitute an individual #' @param given (`character`) Individual first name. #' @param family (`character`) Individual last name. #' @return (`Person`) Person value object. -Person <- function(given = NA_character_, family = NA_character_){ +Person <- function(given = NA_character_, family = NA_character_) { stopifnot(is.character(given), is.character(family)) stopifnot(length(given) == length(family)) - + return( tibble::tibble(given = given, family = family) - %>% tidyr::drop_na(given) + |> tidyr::drop_na(given) ) } @@ -71,15 +73,15 @@ Second, we implement the output type. `Minister()` is the constructor of the ```{r, echo=TRUE} #' @title Minister Value Object Constructor -#' @decription A 'Minister' is a 'Person' with a ministry title. +#' @decription A 'Minister' is a 'Person' with a ministry title. #' @param Person (`Person`) A member of parliament. #' @param title (`character`) A string with one or more ministry titles. #' @return (`Minister`) Minister value object. -Minister <- function(member = Person(), title = NA_character_){ +Minister <- function(member = Person(), title = NA_character_) { stopifnot(is.Person(member), is.character(title)) stopifnot(nrow(member) == length(title) | all(is.na(title))) - - member %>% dplyr::mutate(title = title) + + member |> dplyr::mutate(title = title) } ``` @@ -93,14 +95,14 @@ Third, we write a function that transforms **Person** into **Minister**. #' Then the parliament members are appointed to an office. #' @param memeber (`Person`) A Person value object. #' @return (`Minister`) Minister value object. -appoint_random_ministries <- function(member = Person()){ +appoint_random_ministries <- function(member = Person()) { positions <- c( "Arts, Culture and Heritage", "Finance", "Corrections", "Racing", "Sport and Recreation", "Housing", "Energy and Resources", "Education", "Public Service", "Disability Issues", "Environment", "Justice", "Immigration", "Defence", "Internal Affairs", "Transport" ) - + Minister(member = member, title = sample(positions, size = nrow(member))) } ``` @@ -113,8 +115,8 @@ Finally, we pair parliament members with ministries set.seed(2020) parliament_members <- Person( - given = c("Jacinda", "Grant", "Kelvin", "Megan", "Chris", "Carmel"), - family = c("Ardern", "Robertson", "Davis", "Woods", "Hipkins", "Sepuloni") + given = c("Jacinda", "Grant", "Kelvin", "Megan", "Chris", "Carmel"), + family = c("Ardern", "Robertson", "Davis", "Woods", "Hipkins", "Sepuloni") ) parliament_members @@ -122,7 +124,6 @@ parliament_members appoint_random_ministries(member = parliament_members) ``` - ## Further Reading [Value Object on Wikipedia](https://en.wikipedia.org/wiki/Value_object)