├── .Rbuildignore ├── .github ├── .gitignore ├── CODE_OF_CONDUCT.md └── workflows │ ├── R-CMD-check.yaml │ ├── pkgdown.yaml │ ├── pr-commands.yaml │ └── test-coverage.yaml ├── .gitignore ├── DESCRIPTION ├── NAMESPACE ├── NEWS.md ├── R ├── dispatch.R ├── ftype.R ├── get-method.R ├── is_s3.R ├── methods.R ├── otype.R ├── s3.R ├── s3_class.R └── sloop-package.R ├── README.Rmd ├── README.md ├── _pkgdown.yml ├── codecov.yml ├── cran-comments.md ├── man ├── figures │ └── logo.png ├── ftype.Rd ├── is_s3_generic.Rd ├── otype.Rd ├── s3_class.Rd ├── s3_dispatch.Rd ├── s3_get_method.Rd ├── s3_methods_class.Rd └── sloop-package.Rd ├── pkgdown └── favicon │ ├── apple-touch-icon-120x120.png │ ├── apple-touch-icon-152x152.png │ ├── apple-touch-icon-180x180.png │ ├── apple-touch-icon-60x60.png │ ├── apple-touch-icon-76x76.png │ ├── apple-touch-icon.png │ ├── favicon-16x16.png │ ├── favicon-32x32.png │ └── favicon.ico ├── revdep ├── .gitignore ├── README.md ├── email.yml └── problems.md ├── sloop.Rproj └── tests ├── testthat.R └── testthat ├── _snaps └── dispatch.md ├── test-dispatch.R ├── test-ftype.R ├── test-is_s3.R ├── test-methods.R ├── test-otype.R └── test-s3_class.R /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^revdep$ 2 | ^pkgdown$ 3 | ^_pkgdown\.yml$ 4 | ^docs$ 5 | ^CRAN-RELEASE$ 6 | ^cran-comments\.md$ 7 | ^.*\.Rproj$ 8 | ^\.Rproj\.user$ 9 | ^README\.Rmd$ 10 | ^\.travis\.yml$ 11 | ^codecov\.yml$ 12 | ^\.github$ 13 | -------------------------------------------------------------------------------- /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | We as members, contributors, and leaders pledge to make participation in our 6 | community a harassment-free experience for everyone, regardless of age, body 7 | size, visible or invisible disability, ethnicity, sex characteristics, gender 8 | identity and expression, level of experience, education, socio-economic status, 9 | nationality, personal appearance, race, caste, color, religion, or sexual 10 | identity and orientation. 11 | 12 | We pledge to act and interact in ways that contribute to an open, welcoming, 13 | diverse, inclusive, and healthy community. 14 | 15 | ## Our Standards 16 | 17 | Examples of behavior that contributes to a positive environment for our 18 | community include: 19 | 20 | * Demonstrating empathy and kindness toward other people 21 | * Being respectful of differing opinions, viewpoints, and experiences 22 | * Giving and gracefully accepting constructive feedback 23 | * Accepting responsibility and apologizing to those affected by our mistakes, 24 | and learning from the experience 25 | * Focusing on what is best not just for us as individuals, but for the overall 26 | community 27 | 28 | Examples of unacceptable behavior include: 29 | 30 | * The use of sexualized language or imagery, and sexual attention or advances of 31 | any kind 32 | * Trolling, insulting or derogatory comments, and personal or political attacks 33 | * Public or private harassment 34 | * Publishing others' private information, such as a physical or email address, 35 | without their explicit permission 36 | * Other conduct which could reasonably be considered inappropriate in a 37 | professional setting 38 | 39 | ## Enforcement Responsibilities 40 | 41 | Community leaders are responsible for clarifying and enforcing our standards of 42 | acceptable behavior and will take appropriate and fair corrective action in 43 | response to any behavior that they deem inappropriate, threatening, offensive, 44 | or harmful. 45 | 46 | Community leaders have the right and responsibility to remove, edit, or reject 47 | comments, commits, code, wiki edits, issues, and other contributions that are 48 | not aligned to this Code of Conduct, and will communicate reasons for moderation 49 | decisions when appropriate. 50 | 51 | ## Scope 52 | 53 | This Code of Conduct applies within all community spaces, and also applies when 54 | an individual is officially representing the community in public spaces. 55 | Examples of representing our community include using an official e-mail address, 56 | posting via an official social media account, or acting as an appointed 57 | representative at an online or offline event. 58 | 59 | ## Enforcement 60 | 61 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 62 | reported to the community leaders responsible for enforcement at codeofconduct@posit.co. 63 | All complaints will be reviewed and investigated promptly and fairly. 64 | 65 | All community leaders are obligated to respect the privacy and security of the 66 | reporter of any incident. 67 | 68 | ## Enforcement Guidelines 69 | 70 | Community leaders will follow these Community Impact Guidelines in determining 71 | the consequences for any action they deem in violation of this Code of Conduct: 72 | 73 | ### 1. Correction 74 | 75 | **Community Impact**: Use of inappropriate language or other behavior deemed 76 | unprofessional or unwelcome in the community. 77 | 78 | **Consequence**: A private, written warning from community leaders, providing 79 | clarity around the nature of the violation and an explanation of why the 80 | behavior was inappropriate. A public apology may be requested. 81 | 82 | ### 2. Warning 83 | 84 | **Community Impact**: A violation through a single incident or series of 85 | actions. 86 | 87 | **Consequence**: A warning with consequences for continued behavior. No 88 | interaction with the people involved, including unsolicited interaction with 89 | those enforcing the Code of Conduct, for a specified period of time. This 90 | includes avoiding interactions in community spaces as well as external channels 91 | like social media. Violating these terms may lead to a temporary or permanent 92 | ban. 93 | 94 | ### 3. Temporary Ban 95 | 96 | **Community Impact**: A serious violation of community standards, including 97 | sustained inappropriate behavior. 98 | 99 | **Consequence**: A temporary ban from any sort of interaction or public 100 | communication with the community for a specified period of time. No public or 101 | private interaction with the people involved, including unsolicited interaction 102 | with those enforcing the Code of Conduct, is allowed during this period. 103 | Violating these terms may lead to a permanent ban. 104 | 105 | ### 4. Permanent Ban 106 | 107 | **Community Impact**: Demonstrating a pattern of violation of community 108 | standards, including sustained inappropriate behavior, harassment of an 109 | individual, or aggression toward or disparagement of classes of individuals. 110 | 111 | **Consequence**: A permanent ban from any sort of public interaction within the 112 | community. 113 | 114 | ## Attribution 115 | 116 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], 117 | version 2.1, available at 118 | . 119 | 120 | Community Impact Guidelines were inspired by 121 | [Mozilla's code of conduct enforcement ladder][https://github.com/mozilla/inclusion]. 122 | 123 | For answers to common questions about this code of conduct, see the FAQ at 124 | . Translations are available at . 125 | 126 | [homepage]: https://www.contributor-covenant.org 127 | -------------------------------------------------------------------------------- /.github/workflows/R-CMD-check.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | # 4 | # NOTE: This workflow is overkill for most R packages and 5 | # check-standard.yaml is likely a better choice. 6 | # usethis::use_github_action("check-standard") will install it. 7 | on: 8 | push: 9 | branches: [main, master] 10 | pull_request: 11 | branches: [main, master] 12 | 13 | name: R-CMD-check 14 | 15 | jobs: 16 | R-CMD-check: 17 | runs-on: ${{ matrix.config.os }} 18 | 19 | name: ${{ matrix.config.os }} (${{ matrix.config.r }}) 20 | 21 | strategy: 22 | fail-fast: false 23 | matrix: 24 | config: 25 | - {os: macos-latest, r: 'release'} 26 | 27 | - {os: windows-latest, r: 'release'} 28 | # Use 3.6 to trigger usage of RTools35 29 | - {os: windows-latest, r: '3.6'} 30 | # use 4.1 to check with rtools40's older compiler 31 | - {os: windows-latest, r: '4.1'} 32 | 33 | - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} 34 | - {os: ubuntu-latest, r: 'release'} 35 | - {os: ubuntu-latest, r: 'oldrel-1'} 36 | - {os: ubuntu-latest, r: 'oldrel-2'} 37 | - {os: ubuntu-latest, r: 'oldrel-3'} 38 | - {os: ubuntu-latest, r: 'oldrel-4'} 39 | 40 | env: 41 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 42 | R_KEEP_PKG_SOURCE: yes 43 | 44 | steps: 45 | - uses: actions/checkout@v3 46 | 47 | - uses: r-lib/actions/setup-pandoc@v2 48 | 49 | - uses: r-lib/actions/setup-r@v2 50 | with: 51 | r-version: ${{ matrix.config.r }} 52 | http-user-agent: ${{ matrix.config.http-user-agent }} 53 | use-public-rspm: true 54 | 55 | - uses: r-lib/actions/setup-r-dependencies@v2 56 | with: 57 | extra-packages: any::rcmdcheck 58 | needs: check 59 | 60 | - uses: r-lib/actions/check-r-package@v2 61 | with: 62 | upload-snapshots: true 63 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | jobs: 15 | pkgdown: 16 | runs-on: ubuntu-latest 17 | # Only restrict concurrency for non-PR jobs 18 | concurrency: 19 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 20 | env: 21 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 22 | permissions: 23 | contents: write 24 | steps: 25 | - uses: actions/checkout@v3 26 | 27 | - uses: r-lib/actions/setup-pandoc@v2 28 | 29 | - uses: r-lib/actions/setup-r@v2 30 | with: 31 | use-public-rspm: true 32 | 33 | - uses: r-lib/actions/setup-r-dependencies@v2 34 | with: 35 | extra-packages: any::pkgdown, local::. 36 | needs: website 37 | 38 | - name: Build site 39 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 40 | shell: Rscript {0} 41 | 42 | - name: Deploy to GitHub pages 🚀 43 | if: github.event_name != 'pull_request' 44 | uses: JamesIves/github-pages-deploy-action@v4.4.1 45 | with: 46 | clean: false 47 | branch: gh-pages 48 | folder: docs 49 | -------------------------------------------------------------------------------- /.github/workflows/pr-commands.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | issue_comment: 5 | types: [created] 6 | 7 | name: Commands 8 | 9 | jobs: 10 | document: 11 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/document') }} 12 | name: document 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - uses: r-lib/actions/pr-fetch@v2 20 | with: 21 | repo-token: ${{ secrets.GITHUB_TOKEN }} 22 | 23 | - uses: r-lib/actions/setup-r@v2 24 | with: 25 | use-public-rspm: true 26 | 27 | - uses: r-lib/actions/setup-r-dependencies@v2 28 | with: 29 | extra-packages: any::roxygen2 30 | needs: pr-document 31 | 32 | - name: Document 33 | run: roxygen2::roxygenise() 34 | shell: Rscript {0} 35 | 36 | - name: commit 37 | run: | 38 | git config --local user.name "$GITHUB_ACTOR" 39 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 40 | git add man/\* NAMESPACE 41 | git commit -m 'Document' 42 | 43 | - uses: r-lib/actions/pr-push@v2 44 | with: 45 | repo-token: ${{ secrets.GITHUB_TOKEN }} 46 | 47 | style: 48 | if: ${{ github.event.issue.pull_request && (github.event.comment.author_association == 'MEMBER' || github.event.comment.author_association == 'OWNER') && startsWith(github.event.comment.body, '/style') }} 49 | name: style 50 | runs-on: ubuntu-latest 51 | env: 52 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 53 | steps: 54 | - uses: actions/checkout@v3 55 | 56 | - uses: r-lib/actions/pr-fetch@v2 57 | with: 58 | repo-token: ${{ secrets.GITHUB_TOKEN }} 59 | 60 | - uses: r-lib/actions/setup-r@v2 61 | 62 | - name: Install dependencies 63 | run: install.packages("styler") 64 | shell: Rscript {0} 65 | 66 | - name: Style 67 | run: styler::style_pkg() 68 | shell: Rscript {0} 69 | 70 | - name: commit 71 | run: | 72 | git config --local user.name "$GITHUB_ACTOR" 73 | git config --local user.email "$GITHUB_ACTOR@users.noreply.github.com" 74 | git add \*.R 75 | git commit -m 'Style' 76 | 77 | - uses: r-lib/actions/pr-push@v2 78 | with: 79 | repo-token: ${{ secrets.GITHUB_TOKEN }} 80 | -------------------------------------------------------------------------------- /.github/workflows/test-coverage.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | 9 | name: test-coverage 10 | 11 | jobs: 12 | test-coverage: 13 | runs-on: ubuntu-latest 14 | env: 15 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 16 | 17 | steps: 18 | - uses: actions/checkout@v3 19 | 20 | - uses: r-lib/actions/setup-r@v2 21 | with: 22 | use-public-rspm: true 23 | 24 | - uses: r-lib/actions/setup-r-dependencies@v2 25 | with: 26 | extra-packages: any::covr 27 | needs: coverage 28 | 29 | - name: Test coverage 30 | run: | 31 | covr::codecov( 32 | quiet = FALSE, 33 | clean = FALSE, 34 | install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") 35 | ) 36 | shell: Rscript {0} 37 | 38 | - name: Show testthat output 39 | if: always() 40 | run: | 41 | ## -------------------------------------------------------------------- 42 | find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true 43 | shell: bash 44 | 45 | - name: Upload test results 46 | if: failure() 47 | uses: actions/upload-artifact@v3 48 | with: 49 | name: coverage-test-failures 50 | path: ${{ runner.temp }}/package 51 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | docs/ 2 | .Rproj.user 3 | .Rhistory 4 | .RData 5 | docs 6 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: sloop 2 | Title: Helpers for 'OOP' in R 3 | Version: 1.0.1.9000 4 | Authors@R: c( 5 | person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), 6 | person(given = "Posit Software, PBC", role = c("cph", "fnd")) 7 | ) 8 | Description: A collection of helper functions designed to help you to 9 | better understand object oriented programming in R, particularly using 10 | 'S3'. 11 | License: GPL-3 12 | URL: https://github.com/r-lib/sloop, https://sloop.r-lib.org 13 | BugReports: https://github.com/r-lib/sloop/issues 14 | Depends: 15 | R (>= 3.6) 16 | Imports: 17 | codetools, 18 | crayon, 19 | methods, 20 | purrr, 21 | rlang, 22 | tibble (>= 2.0.1) 23 | Suggests: 24 | covr, 25 | testthat (>= 3.0.0) 26 | Config/Needs/website: tidyverse/tidytemplate 27 | Config/testthat/edition: 3 28 | Encoding: UTF-8 29 | LazyData: true 30 | Roxygen: list(markdown = TRUE) 31 | RoxygenNote: 7.2.3 32 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(print,method_table) 4 | export(ftype) 5 | export(is_s3_generic) 6 | export(is_s3_method) 7 | export(otype) 8 | export(s3_class) 9 | export(s3_dispatch) 10 | export(s3_get_method) 11 | export(s3_methods_class) 12 | export(s3_methods_generic) 13 | export(s4_methods_class) 14 | export(s4_methods_generic) 15 | import(rlang) 16 | importFrom(methods,is) 17 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # sloop (development version) 2 | 3 | * `s3_dispatch()` now works for namespaced function calls (#25, @mgirlich). 4 | 5 | # sloop 1.0.1 6 | 7 | * sloop has a website: http://sloop.r-lib.org/ ! 8 | 9 | * `s3_methods_generic()` returns correct character class with recent 10 | versions of the tibble package (#19) 11 | 12 | * `s4_methods_class()` returns 0 rows instead of an error if no 13 | methods are found (#18). 14 | -------------------------------------------------------------------------------- /R/dispatch.R: -------------------------------------------------------------------------------- 1 | #' Illustrate S3 dispatch 2 | #' 3 | #' @description 4 | #' `s3_dispatch()` prints a list of all possible function names that will be 5 | #' considered for method dispatch. There are four possible states: 6 | #' 7 | #' * `=>` method exists and is found by `UseMethod()`. 8 | #' * `->` method exists and is used by `NextMethod()`. 9 | #' * `*` method exists but is not used. 10 | #' * Nothing (and greyed out in console): method does not exist. 11 | #' 12 | #' Learn more at . 13 | #' 14 | #' @param call Example call to S3 method 15 | #' @param env Environment in which to evaluate call 16 | #' @export 17 | #' @examples 18 | #' x <- Sys.time() 19 | #' s3_dispatch(print(x)) 20 | #' s3_dispatch(is.numeric(x)) 21 | #' s3_dispatch(as.Date(x)) 22 | #' s3_dispatch(sum(x)) 23 | #' 24 | #' # Internal vs. regular generic 25 | #' x1 <- 1 26 | #' x2 <- structure(2, class = "double") 27 | #' 28 | #' my_length <- function(x) UseMethod("my_length") 29 | #' s3_dispatch(my_length(x1)) 30 | #' s3_dispatch(my_length(x2)) 31 | #' 32 | #' length.double <- function(x) 10 33 | #' s3_dispatch(length(x1)) 34 | #' s3_dispatch(length(x2)) 35 | s3_dispatch <- function(call, env = parent.frame()) { 36 | call <- enexpr(call) 37 | if (!is_call(call)) { 38 | stop("`call` must be a function call", call. = FALSE) 39 | } 40 | 41 | f <- call[[1]] 42 | if (is_call(f)) { 43 | n <- length(f) 44 | f <- f[[n]] 45 | } 46 | generic <- as.character(f) 47 | x <- eval(call[[2]], env) 48 | 49 | class <- c(s3_class(x), "default") 50 | names <- paste0(generic, ".", class) 51 | impls <- method_find(generic, class, env = env) 52 | 53 | # Add group generic if necssary 54 | group <- find_group(generic) 55 | if (!is.null(group)) { 56 | names <- c(names, paste0(group, ".", class)) 57 | impls <- c(impls, method_find(group, class, env = env)) 58 | } 59 | 60 | # internal generics can resolve to internal method 61 | if (is_internal_generic(generic)) { 62 | internal <- !is.object(x) 63 | names <- c(names, paste0(generic, " (internal)")) 64 | impls <- c(impls, get(generic)) 65 | } else { 66 | internal <- FALSE 67 | } 68 | 69 | structure( 70 | list( 71 | method = names, 72 | impl = impls, 73 | exists = !purrr::map_lgl(impls, is.null), 74 | to_next = purrr::map_lgl(impls, calls_next_method) 75 | ), 76 | internal = internal, 77 | class = "method_table" 78 | ) 79 | } 80 | 81 | calls_next_method <- function(f) { 82 | if (is.primitive(f) || is.null(f)) { 83 | FALSE 84 | } else { 85 | uses <- codetools::findGlobals(f, merge = FALSE)$functions 86 | any(uses == "NextMethod") 87 | } 88 | 89 | } 90 | 91 | method_find <- function(generic, class, env = parent.frame()) { 92 | purrr::map2(generic, class, utils::getS3method, envir = env, optional = TRUE) 93 | } 94 | 95 | #' @export 96 | print.method_table <- function(x, ...) { 97 | 98 | 99 | if (attr(x, "internal")) { 100 | bullet <- ifelse(x$exists, " *", " ") 101 | bullet[[length(bullet)]] <- "=>" 102 | } else { 103 | first <- TRUE 104 | to_next <- TRUE 105 | 106 | bullet <- character(length(x$exists)) 107 | for (i in seq_along(x$exists)) { 108 | if (!x$exists[[i]]) { 109 | bullet[[i]] <- " " 110 | } else { 111 | if (first) { 112 | bullet[[i]] <- "=>" 113 | first <- FALSE 114 | } else if (to_next) { 115 | bullet[[i]] <- "->" 116 | } else { 117 | bullet[[i]] <- " *" 118 | } 119 | to_next <- (to_next || first) && x$to_next[[i]] 120 | } 121 | } 122 | } 123 | 124 | method <- ifelse(x$exists, x$method, crayon::silver(x$method)) 125 | 126 | cat(paste0(bullet, " ", method, "\n", collapse = ""), sep = "") 127 | invisible(x) 128 | } 129 | 130 | find_group <- function(generic) { 131 | g <- group_generics() 132 | g_table <- stats::setNames(rep(names(g), lengths(g)), unlist(g)) 133 | 134 | if (!generic %in% names(g_table)) 135 | return() 136 | 137 | g_table[[generic]] 138 | } 139 | -------------------------------------------------------------------------------- /R/ftype.R: -------------------------------------------------------------------------------- 1 | #' Determine function type. 2 | #' 3 | #' This function figures out whether the input function is a 4 | #' regular/primitive/internal function, a internal/S3/S4 generic, or a 5 | #' S3/S4/RC method. This is function is slightly simplified as it's possible 6 | #' for a method from one class to be a generic for another class, but that 7 | #' seems like such a bad idea that hopefully no one has done it. 8 | #' 9 | #' @param f unquoted function name 10 | #' @return a character of vector of length 1 or 2. 11 | #' @family object inspection 12 | #' @importFrom methods is 13 | #' @export 14 | #' @examples 15 | #' ftype(`%in%`) 16 | #' ftype(sum) 17 | #' ftype(t.data.frame) 18 | #' ftype(t.test) # Tricky! 19 | #' ftype(writeLines) 20 | #' ftype(unlist) 21 | ftype <- function(f) { 22 | fexpr <- enexpr(f) 23 | env <- caller_env() 24 | 25 | if (!is.function(f) && !is.function(f)) 26 | stop("`f` is not a function", call. = FALSE) 27 | 28 | if (is.primitive(f)) { 29 | c("primitive", if (is_internal_generic(primitive_name(f))) "generic") 30 | } else if (is_internal(f)) { 31 | c("internal", if (is_internal_generic(internal_name(f))) "generic") 32 | } else if (is(f, "standardGeneric")) { 33 | c("S4", "generic") 34 | } else if (is(f, "MethodDefinition")) { 35 | c("S4", "method") 36 | } else if (is(f, "refMethodDef")) { 37 | c("RC", "method") 38 | } else { 39 | if (!is_symbol(fexpr)) { 40 | warning("Determination of S3 status requires function name", call. = FALSE) 41 | gen <- FALSE 42 | mth <- FALSE 43 | } else { 44 | fname <- as.character(fexpr) 45 | gen <- is_s3_generic(fname, env) 46 | mth <- is_s3_method(fname, env) 47 | } 48 | 49 | if (!gen & !mth) { 50 | "function" 51 | } else { 52 | c("S3", if (gen) "generic", if (mth) "method") 53 | } 54 | } 55 | } 56 | 57 | # Hacky method to get name of primitive function 58 | primitive_name <- function(f) { 59 | stopifnot(is.primitive(f)) 60 | 61 | str <- utils::capture.output(print(f)) 62 | match <- regexec(".Primitive\\([\"](.*?)[\"]\\)", str) 63 | regmatches(str, match)[[1]][2] 64 | } 65 | 66 | is_internal <- function(f) { 67 | if (!is.function(f) || is.primitive(f)) 68 | return(FALSE) 69 | calls <- findGlobals(f, merge = FALSE)$functions 70 | any(calls %in% ".Internal") 71 | } 72 | 73 | # fs <- setNames(lapply(ls("package:base"), get), ls("package:base")) 74 | # internal <- Filter(is_internal, fs) 75 | # icall <- sapply(internal, internal_name) 76 | # icall[names(icall) != icall] 77 | internal_name <- function(f) { 78 | 79 | internal_call <- function(x) { 80 | if (is.name(x) || is.atomic(x)) return(NULL) 81 | if (identical(x[[1]], quote(.Internal))) return(x) 82 | 83 | # Work backwards since likely to be near end last 84 | # (and e.g. unlist has multiple .Internal calls) 85 | for (i in rev(seq_along(x))) { 86 | icall <- internal_call(x[[i]]) 87 | if (!is.null(icall)) return(icall) 88 | } 89 | NULL 90 | } 91 | call <- internal_call(body(f)) 92 | as.character(call[[2]][[1]]) 93 | } 94 | -------------------------------------------------------------------------------- /R/get-method.R: -------------------------------------------------------------------------------- 1 | #' Find S3 method from its name 2 | #' 3 | #' @param name A string or unquoted symbol 4 | #' @return A function, or an error stating why the method could not be 5 | #' found 6 | #' @export 7 | #' @examples 8 | #' s3_get_method(mean.Date) 9 | #' s3_get_method(weighted.mean.Date) 10 | s3_get_method <- function(name) { 11 | name <- ensym(name) 12 | 13 | method <- parse_method(as.character(name)) 14 | if (is.null(method)) { 15 | stop("Could not find generic", call. = FALSE) 16 | } 17 | 18 | fun <- method_find(method[[1]], method[[2]])[[1]] 19 | if (is.null(fun)) { 20 | stop("Could not find method", call. = FALSE) 21 | } 22 | 23 | fun 24 | } 25 | -------------------------------------------------------------------------------- /R/is_s3.R: -------------------------------------------------------------------------------- 1 | #' Determine if a function is an S3 generic or S3 method. 2 | #' 3 | #' `is_s3_generic()` compares name checks for both internal and regular 4 | #' generics. `is_s3_method()` builds names of all possible generics for that 5 | #' function and then checks if any of them actually is a generic. 6 | #' 7 | #' @param fname Name of function as a string. Need name of function because 8 | #' it's impossible to determine whether or not a function is a S3 method 9 | #' based only on its contents. 10 | #' @param env Environment to search in. 11 | #' @export 12 | #' @examples 13 | #' is_s3_generic("mean") 14 | #' is_s3_generic("sum") 15 | #' is_s3_generic("[[") 16 | #' is_s3_generic("unlist") 17 | #' is_s3_generic("runif") 18 | #' 19 | #' is_s3_method("t.data.frame") 20 | #' is_s3_method("t.test") # Just tricking! 21 | #' is_s3_method("as.data.frame") 22 | #' is_s3_method("mean.Date") 23 | is_s3_generic <- function(fname, env = parent.frame()) { 24 | stopifnot(is.character(fname), length(fname) == 1) 25 | 26 | f <- get(fname, env, mode = "function") 27 | 28 | if (is.primitive(f) || is_internal(f)) { 29 | is_internal_generic(fname) 30 | } else { 31 | uses <- codetools::findGlobals(f, merge = FALSE)$functions 32 | any(uses == "UseMethod") 33 | } 34 | } 35 | 36 | #' @rdname is_s3_generic 37 | #' @export 38 | is_s3_method <- function(fname, env = parent.frame()) { 39 | stopifnot(is.character(fname), length(fname) == 1) 40 | !is.null(parse_method(fname, env)) 41 | } 42 | 43 | stop_list <- function() { 44 | if (getRversion() < "3.3.0") { 45 | getNamespace("tools")[[".make_S3_methods_stop_list"]](NULL) 46 | } else { 47 | tools::nonS3methods(NULL) 48 | } 49 | } 50 | 51 | # Returns character vector of length 2, or 52 | parse_method <- function(name, env = parent.frame()) { 53 | if (name %in% stop_list()) return(NULL) 54 | 55 | pieces <- strsplit(name, ".", fixed = TRUE)[[1]] 56 | n <- length(pieces) 57 | 58 | # No . in name, so can't be method 59 | if (n == 1) return(NULL) 60 | 61 | for (i in seq_len(n - 1)) { 62 | generic <- paste0(pieces[seq_len(i)], collapse = ".") 63 | class <- paste0(pieces[(i + 1):n], collapse = ".") 64 | 65 | if (exists(generic, env) && is_s3_generic(generic, env)) 66 | return(c(generic, class)) 67 | } 68 | NULL 69 | } 70 | 71 | is_internal <- function(f) { 72 | calls <- codetools::findGlobals(f, merge = FALSE)$functions 73 | any(calls %in% ".Internal") 74 | } 75 | 76 | is_internal_generic <- function(x) { 77 | x %in% internal_generics() 78 | } 79 | 80 | group_generics <- function() { 81 | # S3 group generics can be defined by combining S4 group generics 82 | groups <- list( 83 | Ops = c("Arith", "Compare", "Logic"), 84 | Math = c("Math", "Math2"), 85 | Summary = "Summary", 86 | Complex = "Complex" 87 | ) 88 | 89 | lapply(groups, function(x) unlist(lapply(x, methods::getGroupMembers))) 90 | } 91 | 92 | internal_generics <- function() { 93 | group <- unlist(group_generics(), use.names = FALSE) 94 | primitive <- .S3PrimitiveGenerics 95 | 96 | # Extracted from ?"internal generic" 97 | internal <- c("[", "[[", "$", "[<-", "[[<-", "$<-", "unlist", 98 | "cbind", "rbind", "as.vector") 99 | 100 | c(group, primitive, internal) 101 | } 102 | -------------------------------------------------------------------------------- /R/methods.R: -------------------------------------------------------------------------------- 1 | #' List methods for a S3 or S4 generic (or class) 2 | #' 3 | #' Returns information about all methods belong to a generic or a class. 4 | #' In S3 and S4, methods belong to a generic, but it is often useful to see what 5 | #' generics have been provided methods for a given class. These are 6 | #' wrappers around [utils::methods()], which returns a lot of useful information 7 | #' in an attribute. 8 | #' 9 | #' @param x Name of class or generic 10 | #' @return A tibble with columns `generic`, `visible`, `class`, `visible`, 11 | #' and `source`. 12 | #' @export 13 | #' @examples 14 | #' s3_methods_class("Date") 15 | #' s3_methods_generic("anova") 16 | #' 17 | #' s4_methods_class("Date") 18 | #' s4_methods_generic("anova") 19 | s3_methods_class <- function(x) { 20 | methods <- methods_class(x) 21 | methods <- methods[!methods$isS4, ] 22 | methods$isS4 <- NULL 23 | 24 | methods 25 | } 26 | 27 | #' @export 28 | #' @rdname s3_methods_class 29 | s3_methods_generic <- function(x) { 30 | methods <- methods_generic(x) 31 | methods <- methods[!methods$isS4, ] 32 | methods$isS4 <- NULL 33 | 34 | methods 35 | } 36 | 37 | 38 | #' @export 39 | #' @rdname s3_methods_class 40 | s4_methods_class <- function(x) { 41 | methods <- methods_class(x) 42 | methods <- methods[methods$isS4, ] 43 | methods$isS4 <- NULL 44 | 45 | methods 46 | } 47 | 48 | #' @export 49 | #' @rdname s3_methods_class 50 | s4_methods_generic <- function(x) { 51 | methods <- methods_generic(x) 52 | methods <- methods[methods$isS4, ] 53 | methods$isS4 <- NULL 54 | 55 | methods 56 | } 57 | 58 | methods_class <- function(x) { 59 | info <- attr(utils::methods(class = x), "info") 60 | info <- tibble::as_tibble(info) 61 | info <- tibble::rownames_to_column(info, "method") 62 | 63 | info$class <- rep(x, length = nrow(info)) 64 | info$source <- as.character(info$from) 65 | 66 | info[c("generic", "class", "visible", "source", "isS4")] 67 | } 68 | 69 | methods_generic <- function(x) { 70 | info <- attr(utils::methods(x), "info") 71 | info <- tibble::as_tibble(info, rownames = "method") 72 | 73 | generic_esc <- gsub("([.\\[])", "\\\\\\1", x) 74 | info$class <- gsub(paste0("^", generic_esc, "[.,]"), "", info$method) 75 | info$class <- gsub("-method$", "", info$class) 76 | info$source <- gsub(paste0(" for ", generic_esc), "", info$from) 77 | 78 | info[c("generic", "class", "visible", "source", "isS4")] 79 | } 80 | 81 | # Needed for testing 82 | sloop_foo <- function(x) UseMethod("sloop_foo") 83 | sloop_foo.blah <- function(x) 1 84 | -------------------------------------------------------------------------------- /R/otype.R: -------------------------------------------------------------------------------- 1 | #' Determine the type of an object 2 | #' 3 | #' Tells you if you're dealing with an base, S3, S4, RC, or R6 object. 4 | #' 5 | #' @param x An object 6 | #' @export 7 | #' @examples 8 | #' otype(1:10) 9 | #' otype(mtcars) 10 | otype <- function(x) { 11 | if (!is.object(x)) { 12 | "base" 13 | } else if (!isS4(x)) { 14 | if (!inherits(x, "R6")) { 15 | "S3" 16 | } else { 17 | "R6" 18 | } 19 | } else { 20 | if (!is(x, "refClass")) { 21 | "S4" 22 | } else { 23 | "RC" 24 | } 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /R/s3.R: -------------------------------------------------------------------------------- 1 | #' @import rlang 2 | NULL 3 | -------------------------------------------------------------------------------- /R/s3_class.R: -------------------------------------------------------------------------------- 1 | #' Compute the S3 class of an object 2 | #' 3 | #' Compared to [class()], this always returns the class vector that is 4 | #' used for dispatch. This is most important for objects where the 5 | #' class attribute has not been set. 6 | #' 7 | #' @param x A primitive type 8 | #' @export 9 | #' @examples 10 | #' s3_class(NULL) 11 | #' 12 | #' s3_class(logical()) 13 | #' s3_class(integer()) 14 | #' s3_class(numeric()) 15 | #' s3_class(character()) 16 | #' 17 | #' s3_class(matrix()) 18 | #' s3_class(matrix(1)) 19 | #' 20 | #' s3_class(array()) 21 | #' s3_class(array(1)) 22 | s3_class <- function(x) { 23 | if (is.object(x)) { 24 | class(x) 25 | } else { 26 | c( 27 | dim_class(x), 28 | lang_class(x), 29 | base_class(x), 30 | if (is.integer(x) || is.double(x)) "numeric" 31 | ) 32 | } 33 | } 34 | 35 | dim_class <- function(x) { 36 | d <- length(dim(x)) 37 | 38 | if (d == 0) { 39 | character() 40 | } else if (d == 2) { 41 | "matrix" 42 | } else { 43 | "array" 44 | } 45 | } 46 | 47 | lang_class <- function(x) { 48 | if (typeof(x) == "language") { 49 | setdiff(class(x), "call") 50 | } else { 51 | character() 52 | } 53 | } 54 | 55 | # Basically mode, but don't mess with numeric and integer 56 | base_class <- function(x) { 57 | type <- typeof(x) 58 | switch(type, 59 | language = "call", 60 | closure = , 61 | builtin = , 62 | special = "function", 63 | symbol = "name", 64 | type 65 | ) 66 | } 67 | -------------------------------------------------------------------------------- /R/sloop-package.R: -------------------------------------------------------------------------------- 1 | #' @keywords internal 2 | "_PACKAGE" 3 | 4 | ## usethis namespace: start 5 | ## usethis namespace: end 6 | NULL 7 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: github_document 3 | --- 4 | 5 | 6 | 7 | ```{r, include = FALSE} 8 | knitr::opts_chunk$set( 9 | collapse = TRUE, 10 | comment = "#>", 11 | fig.path = "man/figures/README-" 12 | ) 13 | ``` 14 | 15 | # sloop sloop website 16 | 17 | 18 | [![CRAN status](https://www.r-pkg.org/badges/version/sloop)](https://cran.r-project.org/package=sloop) 19 | [![R-CMD-check](https://github.com/r-lib/sloop/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/sloop/actions/workflows/R-CMD-check.yaml) 20 | [![Codecov test coverage](https://codecov.io/gh/r-lib/sloop/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/sloop?branch=main) 21 | 22 | 23 | The goal of sloop is to provide tools to help you interactively explore and understand object oriented programming in R, particularly with S3. 24 | 25 | Please note that unlike other [r-lib](https://github.com/r-lib) packages, sloop only works with R 3.3 and later. 26 | 27 | ## Installation 28 | 29 | You can install sloop from github with: 30 | 31 | ```{r gh-installation, eval = FALSE} 32 | # install.packages("pak") 33 | pak::pak("r-lib/sloop") 34 | ``` 35 | 36 | ## Usage 37 | 38 | ```{r setup} 39 | library(sloop) 40 | ``` 41 | 42 | sloop provides a variety of tools for understanding how S3 works. The most useful is probably `s3_dispatch()`. Given a function call, it shows the set of methods that are considered, found, and actually called: 43 | 44 | ```{r} 45 | s3_dispatch(print(Sys.time())) 46 | ``` 47 | 48 | To the best of my ability it covers all the details of S3 method dispatch including group generics, internal generics, implicit classes, and use of `NextMethod()` (indicated by `->`): 49 | 50 | ```{r} 51 | # Implicit class 52 | x <- matrix(1:6, nrow = 2) 53 | s3_dispatch(print(x)) 54 | 55 | # Internal generic 56 | length.numeric <- function(x) 10 57 | s3_dispatch(length(x)) 58 | 59 | s3_dispatch(length(structure(x, class = "numeric"))) 60 | 61 | # NextMethod 62 | s3_dispatch(Sys.Date()[1]) 63 | 64 | # group generic + NextMethod() 65 | s3_dispatch(sum(Sys.Date())) 66 | ``` 67 | 68 | It also provides tools for determing what type of function or object you're dealing with: 69 | 70 | ```{r} 71 | ftype(t) 72 | ftype(t.test) 73 | ftype(t.data.frame) 74 | 75 | otype(1:10) 76 | otype(mtcars) 77 | otype(R6::R6Class()$new()) 78 | ``` 79 | 80 | And for retrieving the methods associated with a generic or class: 81 | 82 | ```{r} 83 | s3_methods_class("factor") 84 | 85 | s3_methods_generic("summary") 86 | ``` 87 | 88 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # sloop sloop website 5 | 6 | 7 | 8 | [![CRAN 9 | status](https://www.r-pkg.org/badges/version/sloop)](https://cran.r-project.org/package=sloop) 10 | [![R-CMD-check](https://github.com/r-lib/sloop/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/sloop/actions/workflows/R-CMD-check.yaml) 11 | [![Codecov test 12 | coverage](https://codecov.io/gh/r-lib/sloop/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/sloop?branch=main) 13 | 14 | 15 | The goal of sloop is to provide tools to help you interactively explore 16 | and understand object oriented programming in R, particularly with S3. 17 | 18 | Please note that unlike other [r-lib](https://github.com/r-lib) 19 | packages, sloop only works with R 3.3 and later. 20 | 21 | ## Installation 22 | 23 | You can install sloop from github with: 24 | 25 | ``` r 26 | # install.packages("pak") 27 | pak::pak("r-lib/sloop") 28 | ``` 29 | 30 | ## Usage 31 | 32 | ``` r 33 | library(sloop) 34 | ``` 35 | 36 | sloop provides a variety of tools for understanding how S3 works. The 37 | most useful is probably `s3_dispatch()`. Given a function call, it shows 38 | the set of methods that are considered, found, and actually called: 39 | 40 | ``` r 41 | s3_dispatch(print(Sys.time())) 42 | #> => print.POSIXct 43 | #> print.POSIXt 44 | #> * print.default 45 | ``` 46 | 47 | To the best of my ability it covers all the details of S3 method 48 | dispatch including group generics, internal generics, implicit classes, 49 | and use of `NextMethod()` (indicated by `->`): 50 | 51 | ``` r 52 | # Implicit class 53 | x <- matrix(1:6, nrow = 2) 54 | s3_dispatch(print(x)) 55 | #> print.matrix 56 | #> print.integer 57 | #> print.numeric 58 | #> => print.default 59 | 60 | # Internal generic 61 | length.numeric <- function(x) 10 62 | s3_dispatch(length(x)) 63 | #> length.matrix 64 | #> length.integer 65 | #> * length.numeric 66 | #> length.default 67 | #> => length (internal) 68 | 69 | s3_dispatch(length(structure(x, class = "numeric"))) 70 | #> => length.numeric 71 | #> length.default 72 | #> * length (internal) 73 | 74 | # NextMethod 75 | s3_dispatch(Sys.Date()[1]) 76 | #> => [.Date 77 | #> [.default 78 | #> -> [ (internal) 79 | 80 | # group generic + NextMethod() 81 | s3_dispatch(sum(Sys.Date())) 82 | #> sum.Date 83 | #> sum.default 84 | #> => Summary.Date 85 | #> Summary.default 86 | #> -> sum (internal) 87 | ``` 88 | 89 | It also provides tools for determing what type of function or object 90 | you’re dealing with: 91 | 92 | ``` r 93 | ftype(t) 94 | #> [1] "S3" "generic" 95 | ftype(t.test) 96 | #> [1] "S3" "generic" 97 | ftype(t.data.frame) 98 | #> [1] "S3" "method" 99 | 100 | otype(1:10) 101 | #> [1] "base" 102 | otype(mtcars) 103 | #> [1] "S3" 104 | otype(R6::R6Class()$new()) 105 | #> [1] "R6" 106 | ``` 107 | 108 | And for retrieving the methods associated with a generic or class: 109 | 110 | ``` r 111 | s3_methods_class("factor") 112 | #> # A tibble: 28 × 4 113 | #> generic class visible source 114 | #> 115 | #> 1 [ factor TRUE base 116 | #> 2 [[ factor TRUE base 117 | #> 3 [[<- factor TRUE base 118 | #> 4 [<- factor TRUE base 119 | #> 5 all.equal factor TRUE base 120 | #> 6 as.character factor TRUE base 121 | #> 7 as.data.frame factor TRUE base 122 | #> 8 as.Date factor TRUE base 123 | #> 9 as.list factor TRUE base 124 | #> 10 as.logical factor TRUE base 125 | #> # ℹ 18 more rows 126 | 127 | s3_methods_generic("summary") 128 | #> # A tibble: 39 × 4 129 | #> generic class visible source 130 | #> 131 | #> 1 summary aov TRUE stats 132 | #> 2 summary aovlist FALSE registered S3method 133 | #> 3 summary aspell FALSE registered S3method 134 | #> 4 summary check_packages_in_dir FALSE registered S3method 135 | #> 5 summary connection TRUE base 136 | #> 6 summary data.frame TRUE base 137 | #> 7 summary Date TRUE base 138 | #> 8 summary default TRUE base 139 | #> 9 summary ecdf FALSE registered S3method 140 | #> 10 summary factor TRUE base 141 | #> # ℹ 29 more rows 142 | ``` 143 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: https://sloop.r-lib.org 2 | 3 | template: 4 | package: tidytemplate 5 | bootstrap: 5 6 | 7 | includes: 8 | in_header: | 9 | 10 | 11 | development: 12 | mode: auto 13 | -------------------------------------------------------------------------------- /codecov.yml: -------------------------------------------------------------------------------- 1 | comment: false 2 | 3 | coverage: 4 | status: 5 | project: 6 | default: 7 | target: auto 8 | threshold: 1% 9 | informational: true 10 | patch: 11 | default: 12 | target: auto 13 | threshold: 1% 14 | informational: true 15 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | ## R CMD check results 2 | 3 | 0 errors | 0 warnings | 1 note 4 | 5 | ## revdepcheck results 6 | 7 | We checked 0 reverse dependencies, comparing R CMD check results across CRAN and dev versions of this package. 8 | 9 | * We saw 0 new problems 10 | * We failed to check 0 packages 11 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/man/figures/logo.png -------------------------------------------------------------------------------- /man/ftype.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/ftype.R 3 | \name{ftype} 4 | \alias{ftype} 5 | \title{Determine function type.} 6 | \usage{ 7 | ftype(f) 8 | } 9 | \arguments{ 10 | \item{f}{unquoted function name} 11 | } 12 | \value{ 13 | a character of vector of length 1 or 2. 14 | } 15 | \description{ 16 | This function figures out whether the input function is a 17 | regular/primitive/internal function, a internal/S3/S4 generic, or a 18 | S3/S4/RC method. This is function is slightly simplified as it's possible 19 | for a method from one class to be a generic for another class, but that 20 | seems like such a bad idea that hopefully no one has done it. 21 | } 22 | \examples{ 23 | ftype(`\%in\%`) 24 | ftype(sum) 25 | ftype(t.data.frame) 26 | ftype(t.test) # Tricky! 27 | ftype(writeLines) 28 | ftype(unlist) 29 | } 30 | \concept{object inspection} 31 | -------------------------------------------------------------------------------- /man/is_s3_generic.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/is_s3.R 3 | \name{is_s3_generic} 4 | \alias{is_s3_generic} 5 | \alias{is_s3_method} 6 | \title{Determine if a function is an S3 generic or S3 method.} 7 | \usage{ 8 | is_s3_generic(fname, env = parent.frame()) 9 | 10 | is_s3_method(fname, env = parent.frame()) 11 | } 12 | \arguments{ 13 | \item{fname}{Name of function as a string. Need name of function because 14 | it's impossible to determine whether or not a function is a S3 method 15 | based only on its contents.} 16 | 17 | \item{env}{Environment to search in.} 18 | } 19 | \description{ 20 | \code{is_s3_generic()} compares name checks for both internal and regular 21 | generics. \code{is_s3_method()} builds names of all possible generics for that 22 | function and then checks if any of them actually is a generic. 23 | } 24 | \examples{ 25 | is_s3_generic("mean") 26 | is_s3_generic("sum") 27 | is_s3_generic("[[") 28 | is_s3_generic("unlist") 29 | is_s3_generic("runif") 30 | 31 | is_s3_method("t.data.frame") 32 | is_s3_method("t.test") # Just tricking! 33 | is_s3_method("as.data.frame") 34 | is_s3_method("mean.Date") 35 | } 36 | -------------------------------------------------------------------------------- /man/otype.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/otype.R 3 | \name{otype} 4 | \alias{otype} 5 | \title{Determine the type of an object} 6 | \usage{ 7 | otype(x) 8 | } 9 | \arguments{ 10 | \item{x}{An object} 11 | } 12 | \description{ 13 | Tells you if you're dealing with an base, S3, S4, RC, or R6 object. 14 | } 15 | \examples{ 16 | otype(1:10) 17 | otype(mtcars) 18 | } 19 | -------------------------------------------------------------------------------- /man/s3_class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/s3_class.R 3 | \name{s3_class} 4 | \alias{s3_class} 5 | \title{Compute the S3 class of an object} 6 | \usage{ 7 | s3_class(x) 8 | } 9 | \arguments{ 10 | \item{x}{A primitive type} 11 | } 12 | \description{ 13 | Compared to \code{\link[=class]{class()}}, this always returns the class vector that is 14 | used for dispatch. This is most important for objects where the 15 | class attribute has not been set. 16 | } 17 | \examples{ 18 | s3_class(NULL) 19 | 20 | s3_class(logical()) 21 | s3_class(integer()) 22 | s3_class(numeric()) 23 | s3_class(character()) 24 | 25 | s3_class(matrix()) 26 | s3_class(matrix(1)) 27 | 28 | s3_class(array()) 29 | s3_class(array(1)) 30 | } 31 | -------------------------------------------------------------------------------- /man/s3_dispatch.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/dispatch.R 3 | \name{s3_dispatch} 4 | \alias{s3_dispatch} 5 | \title{Illustrate S3 dispatch} 6 | \usage{ 7 | s3_dispatch(call, env = parent.frame()) 8 | } 9 | \arguments{ 10 | \item{call}{Example call to S3 method} 11 | 12 | \item{env}{Environment in which to evaluate call} 13 | } 14 | \description{ 15 | \code{s3_dispatch()} prints a list of all possible function names that will be 16 | considered for method dispatch. There are four possible states: 17 | \itemize{ 18 | \item \verb{=>} method exists and is found by \code{UseMethod()}. 19 | \item \verb{->} method exists and is used by \code{NextMethod()}. 20 | \item \code{*} method exists but is not used. 21 | \item Nothing (and greyed out in console): method does not exist. 22 | } 23 | 24 | Learn more at \url{https://adv-r.hadley.nz/s3.html}. 25 | } 26 | \examples{ 27 | x <- Sys.time() 28 | s3_dispatch(print(x)) 29 | s3_dispatch(is.numeric(x)) 30 | s3_dispatch(as.Date(x)) 31 | s3_dispatch(sum(x)) 32 | 33 | # Internal vs. regular generic 34 | x1 <- 1 35 | x2 <- structure(2, class = "double") 36 | 37 | my_length <- function(x) UseMethod("my_length") 38 | s3_dispatch(my_length(x1)) 39 | s3_dispatch(my_length(x2)) 40 | 41 | length.double <- function(x) 10 42 | s3_dispatch(length(x1)) 43 | s3_dispatch(length(x2)) 44 | } 45 | -------------------------------------------------------------------------------- /man/s3_get_method.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/get-method.R 3 | \name{s3_get_method} 4 | \alias{s3_get_method} 5 | \title{Find S3 method from its name} 6 | \usage{ 7 | s3_get_method(name) 8 | } 9 | \arguments{ 10 | \item{name}{A string or unquoted symbol} 11 | } 12 | \value{ 13 | A function, or an error stating why the method could not be 14 | found 15 | } 16 | \description{ 17 | Find S3 method from its name 18 | } 19 | \examples{ 20 | s3_get_method(mean.Date) 21 | s3_get_method(weighted.mean.Date) 22 | } 23 | -------------------------------------------------------------------------------- /man/s3_methods_class.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/methods.R 3 | \name{s3_methods_class} 4 | \alias{s3_methods_class} 5 | \alias{s3_methods_generic} 6 | \alias{s4_methods_class} 7 | \alias{s4_methods_generic} 8 | \title{List methods for a S3 or S4 generic (or class)} 9 | \usage{ 10 | s3_methods_class(x) 11 | 12 | s3_methods_generic(x) 13 | 14 | s4_methods_class(x) 15 | 16 | s4_methods_generic(x) 17 | } 18 | \arguments{ 19 | \item{x}{Name of class or generic} 20 | } 21 | \value{ 22 | A tibble with columns \code{generic}, \code{visible}, \code{class}, \code{visible}, 23 | and \code{source}. 24 | } 25 | \description{ 26 | Returns information about all methods belong to a generic or a class. 27 | In S3 and S4, methods belong to a generic, but it is often useful to see what 28 | generics have been provided methods for a given class. These are 29 | wrappers around \code{\link[utils:methods]{utils::methods()}}, which returns a lot of useful information 30 | in an attribute. 31 | } 32 | \examples{ 33 | s3_methods_class("Date") 34 | s3_methods_generic("anova") 35 | 36 | s4_methods_class("Date") 37 | s4_methods_generic("anova") 38 | } 39 | -------------------------------------------------------------------------------- /man/sloop-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/sloop-package.R 3 | \docType{package} 4 | \name{sloop-package} 5 | \alias{sloop} 6 | \alias{sloop-package} 7 | \title{sloop: Helpers for 'OOP' in R} 8 | \description{ 9 | A collection of helper functions designed to help you to better understand object oriented programming in R, particularly using 'S3'. 10 | } 11 | \seealso{ 12 | Useful links: 13 | \itemize{ 14 | \item \url{https://github.com/r-lib/sloop} 15 | \item \url{https://sloop.r-lib.org} 16 | \item Report bugs at \url{https://github.com/r-lib/sloop/issues} 17 | } 18 | 19 | } 20 | \author{ 21 | \strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} 22 | 23 | Other contributors: 24 | \itemize{ 25 | \item Posit Software, PBC [copyright holder, funder] 26 | } 27 | 28 | } 29 | \keyword{internal} 30 | -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-120x120.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon-120x120.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-152x152.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon-152x152.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-180x180.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon-180x180.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-60x60.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon-60x60.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon-76x76.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon-76x76.png -------------------------------------------------------------------------------- /pkgdown/favicon/apple-touch-icon.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/apple-touch-icon.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-16x16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/favicon-16x16.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon-32x32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/favicon-32x32.png -------------------------------------------------------------------------------- /pkgdown/favicon/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/pkgdown/favicon/favicon.ico -------------------------------------------------------------------------------- /revdep/.gitignore: -------------------------------------------------------------------------------- 1 | checks 2 | library 3 | checks.noindex 4 | library.noindex 5 | data.sqlite 6 | *.html 7 | -------------------------------------------------------------------------------- /revdep/README.md: -------------------------------------------------------------------------------- 1 | # Platform 2 | 3 | |field |value | 4 | |:--------|:----------------------------| 5 | |version |R version 3.5.2 (2018-12-20) | 6 | |os |macOS Mojave 10.14.2 | 7 | |system |x86_64, darwin15.6.0 | 8 | |ui |RStudio | 9 | |language |(EN) | 10 | |collate |en_US.UTF-8 | 11 | |ctype |en_US.UTF-8 | 12 | |tz |America/Chicago | 13 | |date |2019-02-17 | 14 | 15 | # Dependencies 16 | 17 | |package |old |new |Δ | 18 | |:---------|:-----|:----------|:--| 19 | |sloop |1.0.0 |1.0.0.9000 |* | 20 | |fansi |0.4.0 |0.4.0 | | 21 | |pillar |1.3.1 |1.3.1 | | 22 | |pkgconfig |2.0.2 |2.0.2 | | 23 | |purrr |0.3.0 |0.3.0 | | 24 | |rlang |0.3.1 |0.3.1 | | 25 | |tibble |2.0.1 |2.0.1 | | 26 | |utf8 |1.1.4 |1.1.4 | | 27 | 28 | # Revdeps 29 | 30 | -------------------------------------------------------------------------------- /revdep/email.yml: -------------------------------------------------------------------------------- 1 | release_date: ??? 2 | rel_release_date: ??? 3 | my_news_url: ??? 4 | release_version: ??? 5 | release_details: ??? 6 | -------------------------------------------------------------------------------- /revdep/problems.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/r-lib/sloop/cdb79122f426d835464252fd4915e311da3e6346/revdep/problems.md -------------------------------------------------------------------------------- /sloop.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: knitr 13 | LaTeX: XeLaTeX 14 | 15 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageRoxygenize: rd,collate,namespace 22 | -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | # This file is part of the standard setup for testthat. 2 | # It is recommended that you do not modify it. 3 | # 4 | # Where should you do additional test configuration? 5 | # Learn more about the roles of various files in: 6 | # * https://r-pkgs.org/testing-design.html#sec-tests-files-overview 7 | # * https://testthat.r-lib.org/articles/special-files.html 8 | 9 | library(testthat) 10 | library(sloop) 11 | 12 | test_check("sloop") 13 | -------------------------------------------------------------------------------- /tests/testthat/_snaps/dispatch.md: -------------------------------------------------------------------------------- 1 | # has nice output 2 | 3 | Code 4 | s3_dispatch(Sys.Date() + 1) 5 | Output 6 | => +.Date 7 | +.default 8 | * Ops.Date 9 | Ops.default 10 | * + (internal) 11 | Code 12 | s3_dispatch(Sys.Date() * 1) 13 | Output 14 | *.Date 15 | *.default 16 | => Ops.Date 17 | Ops.default 18 | -> * (internal) 19 | 20 | -------------------------------------------------------------------------------- /tests/testthat/test-dispatch.R: -------------------------------------------------------------------------------- 1 | test_that("finds methods in other namespaces", { 2 | mod1 <- glm(mpg ~ wt, data = mtcars) 3 | 4 | out <- s3_dispatch(anova(mod1)) 5 | expect_equal(out$method, c("anova.glm", "anova.lm", "anova.default")) 6 | expect_equal(out$exists, c(TRUE, TRUE, FALSE)) 7 | }) 8 | 9 | test_that("includes internal generics", { 10 | out <- s3_dispatch(length(1)) 11 | expect_length(out$method, 4) 12 | expect_equal(out$method[[4]], "length (internal)") 13 | 14 | out <- s3_dispatch(length(structure(1, class = "integer"))) 15 | expect_length(out$method, 3) 16 | expect_equal(out$method[[3]], "length (internal)") 17 | }) 18 | 19 | test_that("can handle namespaced function call", { 20 | out <- s3_dispatch(base::length(1)) 21 | expect_length(out$method, 4) 22 | expect_equal(out$method[[4]], "length (internal)") 23 | }) 24 | 25 | test_that("includes group generics", { 26 | out <- s3_dispatch(-Sys.Date()) 27 | expect_equal(out$method, c("-.Date", "-.default", "Ops.Date", "Ops.default", "- (internal)")) 28 | expect_equal(out$exists, c(TRUE, FALSE, TRUE, FALSE, TRUE)) 29 | }) 30 | 31 | test_that("has nice output", { 32 | expect_snapshot({ 33 | s3_dispatch(Sys.Date() + 1) 34 | s3_dispatch(Sys.Date() * 1) 35 | }) 36 | }) 37 | -------------------------------------------------------------------------------- /tests/testthat/test-ftype.R: -------------------------------------------------------------------------------- 1 | test_that("functions return as expected", { 2 | f <- function(x) x 3 | expect_equal(ftype(f), "function") 4 | expect_equal(ftype(sum), c("primitive", "generic")) 5 | expect_equal(ftype(unlist), c("internal", "generic")) 6 | }) 7 | 8 | test_that("various flavours of S3 return as expected", { 9 | expect_equal(ftype(t), c("S3", "generic")) 10 | expect_equal(ftype(t.data.frame), c("S3", "method")) 11 | expect_equal(ftype(t.test), c("S3", "generic")) 12 | }) 13 | 14 | test_that("warns when trying to find S3 status of inline function", { 15 | expect_warning(ftype(function(x) x), "requires function name") 16 | }) 17 | 18 | test_that("function can be both S3 generic and method", { 19 | f <- function(x) UseMethod("f") 20 | f.foo <- function(x) UseMethod("f.foo") 21 | 22 | expect_equal(ftype(f.foo), c("S3", "generic", "method")) 23 | }) 24 | 25 | test_that("S4 methods and generics return as expected", { 26 | e <- attach(NULL, name = "test") 27 | on.exit(detach("test")) 28 | 29 | A <- setClass("A", contains = list(), where = e) 30 | 31 | setGeneric("f", function(x) 1, where = e) 32 | f <- getGeneric("f", where = e) 33 | expect_equal(ftype(f), c("S4", "generic")) 34 | 35 | setMethod("f", signature(x = "A"), function(x) 1, where = e) 36 | m <- getMethod("f", signature(x = "A"), where = e) 37 | expect_equal(ftype(m), c("S4", "method")) 38 | }) 39 | 40 | test_that("RC methods return as expected", { 41 | B <- setRefClass("B", methods = list(f = function(x) x)) 42 | b <- B$new() 43 | 44 | expect_equal(ftype(b$f), c("RC", "method")) 45 | }) 46 | -------------------------------------------------------------------------------- /tests/testthat/test-is_s3.R: -------------------------------------------------------------------------------- 1 | test_that("works with internal and regular generics", { 2 | expect_true(is_s3_generic("sum")) 3 | expect_true(is_s3_generic("[[")) 4 | expect_true(is_s3_generic("mean")) 5 | }) 6 | -------------------------------------------------------------------------------- /tests/testthat/test-methods.R: -------------------------------------------------------------------------------- 1 | test_that("multiplication works", { 2 | registerS3method("sloop_foo", "blah", function(x) {}, envir = asNamespace("sloop")) 3 | 4 | out <- s3_methods_generic("sloop_foo") 5 | expect_equal(nrow(out), 1) 6 | expect_equal(out$generic, "sloop_foo") 7 | expect_equal(out$class, "blah") 8 | }) 9 | -------------------------------------------------------------------------------- /tests/testthat/test-otype.R: -------------------------------------------------------------------------------- 1 | test_that("otype yields correct value for sample inputs", { 2 | expect_equal(otype(1:10), "base") 3 | expect_equal(otype(mtcars), "S3") 4 | }) 5 | -------------------------------------------------------------------------------- /tests/testthat/test-s3_class.R: -------------------------------------------------------------------------------- 1 | test_that("integer and double have final component", { 2 | expect_equal(s3_class(1:10), c("integer", "numeric")) 3 | expect_equal(s3_class(matrix(1.5, 1, 1)), c("matrix", "double", "numeric")) 4 | expect_equal(s3_class(array(1L, c(1, 1, 1))), c("array", "integer", "numeric")) 5 | expect_equal(s3_class(array(1L, 1)), c("array", "integer", "numeric")) 6 | }) 7 | 8 | test_that("s3_class matches class for language objects", { 9 | expect_equal(s3_class(quote(x)), "name") 10 | expect_equal(s3_class(quote(1 + 2)), "call") 11 | expect_equal(s3_class(quote((1 + 2))), c("(", "call")) 12 | expect_equal(s3_class(quote({1 + 2})), c("{", "call")) 13 | }) 14 | 15 | test_that("s3_class matches class for functions", { 16 | expect_equal(s3_class(function() {}), "function") 17 | expect_equal(s3_class(sum), "function") 18 | expect_equal(s3_class(`[`), "function") 19 | }) 20 | 21 | test_that("calls class for S3 objects", { 22 | x <- ordered(character()) 23 | expect_equal(s3_class(x), class(x)) 24 | }) 25 | --------------------------------------------------------------------------------