testextra/0000755000175100001440000000000013576367061012331 5ustar hornikuserstestextra/NAMESPACE0000644000175100001440000000027213372405355013542 0ustar hornikusersexportPattern("^[[:alpha:]]+") import(methods) import(parsetools) import(pkgcond) import(testthat) import(postlogic) importFrom(assertthat,is.string) importFrom(assertthat,validate_that)testextra/README.md0000644000175100001440000001363313411530303013571 0ustar hornikusers testextra ==================================================================== [![Travis build status](https://travis-ci.org/RDocTaskForce/testextra.svg?branch=master)](https://travis-ci.org/RDocTaskForce/testextra) [![Coverage](https://codecov.io/github/RDocTaskForce/testextra/coverage.svg?branch=master)](https://codecov.io/github/RDocTaskForce/testextra?branch=master) [![CRAN status](https://www.r-pkg.org/badges/version/testextra)](https://cran.r-project.org/package=testextra) [![life-cycle](https://img.shields.io/badge/lifecycle-experimental-orange.svg)](https://www.tidyverse.org/lifecycle/#experimental) The goal of testextra is to facilitate extraction of tests embedded in source code. Installation ------------ You will be able to install the released version of testextra from [CRAN](https://CRAN.R-project.org) once it is released with: ``` r install.packages("testextra") ``` Until then or if you wish to get the latest version prior to release you may install directly from GitHub with: ``` r remotes::install_github("RDocTaskForce/testextra") ``` Including Tests in Source Code. ------------------------------- To include tests in source code put your tests following the function definition nested in an `if(FALSE){...}` block and tag it with a `#@testing` block tag. ``` r #' Hello World Example hello_world <- function(){ message("hello world!") } if(FALSE){#@testing expect_message(hello_world(), "hello world!") } ``` Assuming the preceding code is in a package file `./R/hello_world.R` running the `extract_tests()` command will create a file `./tests/testthat/test-hello_world.R` with the contents as below. ``` r #! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `hello_world.R`') #line 5 "./R/hello_world.R" test_that('hello_world', {#@testing expect_message(hello_world(), "hello world!") }) ``` When run, if there are error messages, the line given will be the line and file from the original source code. Combination Functions --------------------- The functions `test()` and `test_file()` provided in `testextra` will both extract tests from source files, run said tests, and output the results. `test()` operates on a package as a whole or a subset of a package by setting the filter argument, see the help file for details. `test_file()` is intended to work with the [RStudio](http://rstudio.com) GUI. It takes the currently selected file, extracts tests and runs the tests. This way a tests may be run only for the current file being evaluated. Both `test()` and `test_file()` are available through the add-ins, and made accessible through the menu of RStudio. Other Helpers ------------- The 'testextra\` package provides a number of useful testing functions to use when testing code. ### Inheritance - **`all_inherit()`** - tests if all elements of a list are of the given class or classes. - **`are()`** - similar to `all_inherit()`, however uses the `is()` mechanism which is more appropriate for S4 classes. - **`is_exactly()`** - Tests if an object is a class, but disallows inheritance. - **`all_are_exactly()`** - The `is_exactly()` test mapped over a list of objects. ### Strings - **`is_nonempty_string()`** - similar to `asssertthat::is.string()` but also ensures that the provided string is not missing (`NA`) and not empty (`""`) - **`is_optional_string()`** - same as `is_nonempty_string()` except does allow a character vector of length 0. ### Validity - **`is_valid()`** - Performs `validObject()` in a manner that is compatible with `validate_that()`, `assert_that()`, or `see_if()` from the `assertthat` package. - **`are_valid()`** - `is_valid()` over a list, which when used with the functions listed above gives the indices of objects that are not valid. - **`expect_valid()`** - Check validity which is to be used with the `testthat` framework. ### Namespaces When testing dynamic class creation and modification, it is often necessary to have a package environment other that the package environment in which the creation functions are defined. For this purpose, `testextra` provides these namespace manipulation functions. - **`new_namespace_env()`** - Create a namespace environment. \*Similar functionality exists in `pkgload`, but is not exposed and registers the namespace by default, which `new_namespace_env()` does not. - **`new_pkg_environment()`** - Create a package environment. Technically a namespace does not have to be a package environment, however that is essentially always the case. This function does allow for registration of the environment as a namespace but does not do so by default. - **`register_namespace`** - Explicitly register a previously created namespace. - **`is_namespace_registered`** - Check if a namespace is registered. ### Others A few other helpers that do not fit into one of the above categories. - **`catch_condition()`** - Evaluates code and captures any signals that may be raised. Useful for capturing and subsequently running multiple tests on the error captured, as an alternative to `expect_error()`, `expect_warning()`, and `expect_message()` from the `testthat` package. - **`class0`** - retrieve the class of an object as a single string. Separates elements by a '/' if there are more than one. *Same functionality as the `knitr::klass()` function.* - **`is_valid_regex`** - Check if a regular expression is valid, not that it does what is intended just that it is valid. Documentation ------------- The `testextra` package is developed by the R Documentation Task Force, an [R Consortium](https://www.r-consortium.org) [Infrastructure Steering Committee working group](https://www.r-consortium.org/projects/isc-working-groups). testextra/man/0000755000175100001440000000000013402562417013072 5ustar hornikuserstestextra/man/covr_files.Rd0000644000175100001440000000077413411527141015517 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coverage.R \name{covr_files} \alias{covr_files} \title{Compute coverage for a group of files.} \usage{ covr_files(filter, pkg = ".", report = TRUE) } \arguments{ \item{filter}{A regular expression filter to apply to the files from \code{pkg}.} \item{pkg}{The package to compute coverage for.} \item{report}{If a report should be constructed and shown.} } \description{ Compute coverage for a group of files. } testextra/man/catch_condition.Rd0000644000175100001440000000166413411527141016513 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/catch_condition.R \name{catch_condition} \alias{catch_condition} \alias{catch_all_conditions} \title{Catch a condition for testing.} \usage{ catch_condition(code) catch_all_conditions(code) } \arguments{ \item{code}{code to run that should assert a condition.} } \description{ This function captures a condition object such as a warning or error, to allow for testing components and classes. } \examples{ (cond <- catch_condition(stop("catch me."))) class(cond) my_fun <- function(){ message("a message") warning("a warning") pkg_message("a package message", scope="test") pkg_warning("a package warning", scope="test") pkg_error("a package error", scope='test') } conditions <- catch_all_conditions(my_fun()) conditions$messages conditions$warnings conditions$error # only one error can be caught at a time. } testextra/man/namespaces.Rd0000644000175100001440000000433413411527141015477 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/new_namespace.R \name{namespaces} \alias{namespaces} \alias{new_namespace_env} \alias{new_pkg_environment} \alias{register_namespace} \alias{unregister_namespace} \alias{is_namespace_registered} \title{Create namespace environments} \usage{ new_namespace_env(name, path = file.path(tempdir()), import = "methods") new_pkg_environment(name = "test package environment", ..., register = FALSE) register_namespace(ns) unregister_namespace(ns) is_namespace_registered(ns) } \arguments{ \item{name}{The name of the environment} \item{path}{An optional path.} \item{import}{Package to include in the imports.} \item{...}{Arguments passed on to \code{new_namespace_env} \describe{ \item{name}{The name of the environment} \item{path}{An optional path.} \item{import}{Package to include in the imports.} }} \item{register}{Should the package namespace be registered?} \item{ns}{a namespace environment or a character name of a namespace.} } \description{ Create and manipulate namespace and test package environments. } \section{Functions}{ \itemize{ \item \code{new_namespace_env}: Create a new namespace environment \item \code{new_pkg_environment}: Create a package environment. All package environments are namespaces but not all namespaces qualify as package environments. \item \code{register_namespace}: Register a namespace \item \code{unregister_namespace}: Remove a namespace from the registry \item \code{is_namespace_registered}: Check if a namespace is registered }} \examples{ ns <- new_namespace_env('my namespace') isNamespace(ns) environmentName(ns) packageName(ns) # not a package pkg <- new_pkg_environment("myPackage") isNamespace(pkg) environmentName(pkg) packageName(pkg) # now a package is_namespace_registered(pkg) # but not registered \dontrun{ asNamespace("myPackage") # so this WILL NOT work. } register_namespace(pkg) is_namespace_registered(pkg) # now registered asNamespace("myPackage") # so this WILL work. unregister_namespace(pkg) is_namespace_registered(pkg) # now unregistered isNamespace(pkg) # but still a namespace } testextra/man/addin_covr_file.Rd0000644000175100001440000000044613411527142016470 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coverage.R \name{addin_covr_file} \alias{addin_covr_file} \title{Add-in for \code{covr_file}} \usage{ addin_covr_file() } \description{ This allows for \link{covr_file} to be run from a menu in RStudio. } testextra/man/extract_tests.Rd0000644000175100001440000000260513411527141016253 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extract_tests.R \name{extract_tests} \alias{extract_tests} \title{Extract tests from source} \usage{ extract_tests(pkg = ".", filter = NULL, verbose = getOption("verbose", FALSE), full.path = NA, force = FALSE) } \arguments{ \item{pkg}{The root directory of the package.} \item{filter}{If specified, only tests from files matching this regular expression are extracted.} \item{verbose}{Print message?} \item{full.path}{Include full file paths in generated files. TRUE, indicates full path, FALSE, indicated only basename, and NA(default) implies path relative to \code{pkg}.} \item{force}{Force test extraction even if the generated test file is newer than the corresponding source file.} } \description{ Use this function to extract tests from package source files. In-source testing blocks are contained in blocks that are prevented from running when sourced by an \code{if(FALSE){...}} statement. It also contains a documentation tag to denote a testing block. } \details{ The first line of the block should look similar to\preformatted{ if(FALSE){#@testing [optional information] ... } } } \examples{ \dontrun{ # Extract all files extract_tests('.') # Extract only files that start with 'Class-' or 'class-' extract_tests('.', filter="^[Cc]lass-.*\\\\.[Rr]$") } } testextra/man/covr-rendering-single.Rd0000644000175100001440000000211513411527141017556 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coverage.R \name{covr-rendering-single} \alias{covr-rendering-single} \alias{.renderSourceRow} \alias{.renderSourceFile} \alias{.single_file_summary} \alias{.renderReport} \title{Rendering for single file report} \usage{ .renderSourceRow(line, source, coverage) .renderSourceFile(lines, file = "source", highlight = TRUE) .single_file_summary(file_stats) .renderReport(coverage, report.file, dir = dirname(report.file), libdir = file.path(dir, "lib")) } \arguments{ \item{line, lines}{Line(s) number} \item{source}{source file} \item{coverage}{The number of times covered} \item{file}{the file in question} \item{highlight}{Highlight the row.} \item{file_stats}{The coverage object for the file.} \item{report.file}{Where to output the HTML report.} \item{dir}{the base directory for the HTML output} \item{libdir}{Where to put html dependencies?} } \description{ These functions facilitate the creation of reports for coverage of a single file. } \concept{coverage} testextra/man/covr-single.Rd0000644000175100001440000000310613411530130015574 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/coverage.R \name{covr-single} \alias{covr-single} \alias{file_coverage} \alias{covr_file} \title{Single File Coverage} \usage{ file_coverage(file = rstudioapi::getSourceEditorContext()$path, pkg = ".", ...) covr_file(coverage = file_coverage(), report.file = NULL, show.report = interactive()) } \arguments{ \item{file}{The file to extract test from and compute coverage.} \item{pkg}{The package \code{file} is associated with.} \item{...}{Arguments passed on to \code{covr::file_coverage} \describe{ \item{source_files}{Character vector of source files with function definitions to measure coverage} \item{test_files}{Character vector of test files with code to test the functions} \item{line_exclusions}{a named list of files with the lines to exclude from each file.} \item{function_exclusions}{a vector of regular expressions matching function names to exclude. Example \code{print\\\\.} to match print methods.} \item{parent_env}{The parent environment to use when sourcing the files.} }} \item{coverage}{Coverage returned from \code{file_coverage()}.} \item{report.file}{Where to save the HTML report.} \item{show.report}{if the HTML report should be displayed.} } \description{ These functions extract tests, run tests and create a report of the coverage for a single file. } \section{Functions}{ \itemize{ \item \code{file_coverage}: Extract tests and compute the coverage for the given file. \item \code{covr_file}: Create a report for a single }} testextra/man/class-expectations.Rd0000644000175100001440000000271013411527141017165 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/inheritance.R \name{class-expectations} \alias{class-expectations} \alias{expect_is_not} \alias{expect_is_exactly} \alias{expect_all_inherit} \title{Class Expectations} \usage{ expect_is_not(object, class, info = NULL, label = NULL) expect_is_exactly(object, class, info = NULL, label = NULL) expect_all_inherit(object, class, info = NULL, label = NULL) } \arguments{ \item{object}{the object in question.} \item{class}{the expected class object is to be.} \item{info}{extra information to be included in the message (useful when writing tests in loops).} \item{label}{object label. When \code{NULL}, computed from deparsed object.} } \description{ These extend the \link[testthat:expect_is]{testthat::expect_is} to have finer grain tests. } \section{Functions}{ \itemize{ \item \code{expect_is_not}: test that an object does \strong{not} inherit from a class. \item \code{expect_is_exactly}: test that an object is exactly a specific class and not a child class. \item \code{expect_all_inherit}: test that all elements of a list inherit a given class. }} \examples{ # Test to make sure an object is not of a class. \dontrun{ # will return an error. expect_is_not(1L, "numeric") } # but this is fine. expect_is_not('a', "numeric") expect_is_exactly('a', "character") } \seealso{ Other class: \code{\link{class-tests}} } \concept{class} testextra/man/expect_valid.Rd0000644000175100001440000000160713411527141016027 0ustar hornikusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/validity.R \name{expect_valid} \alias{expect_valid} \title{Expect an S4 object is valid} \usage{ expect_valid(object, complete = FALSE, info = NULL, label = NULL) } \arguments{ \item{object}{an S4 object to test for validity} \item{complete}{logical; if \code{TRUE}, \code{validObject} is called recursively for each of the slots. The default is \code{FALSE}.} \item{info}{extra information to be included in the message (useful when writing tests in loops).} \item{label}{object label. When \code{NULL}, computed from deparsed object.} } \description{ Similar to \code{\link[=is_valid]{is_valid()}} except designed to work in the \code{\link[testthat:test_that]{testthat::test_that()}} framework. } \seealso{ Other validity-tests: \code{\link{validity-tests}} } \concept{validity-tests} testextra/man/figures/0000755000175100001440000000000013375317063014542 5ustar hornikuserstestextra/man/figures/logo.png0000644000175100001440000002423313375317134016213 0ustar hornikusersPNG  IHDRyXsBIT|d pHYs``֝tEXtSoftwarewww.inkscape.org< IDATxw`TUƟNd3BABJET\Eˊ]ׂJquEB!BHLzr!@ȄL`L_0ssO{9/BTTI|}}\\\ڻ\mwڂ(K5?cǎmkbȡ]| d?3ڦTmm)rr|f~Œ?X.Jߊ/o9.A`":g (>[{ f659888L%Jwt<0 UUjKM(V,rEH$oxӥю WkjE\JMl3FQ_INNjՋhe:}+`*Ϡ~dMb_`W\USYr27w6o\}o:!!!h S2 BfhJ P##[wL"*6o-P"$qFt###]Z[ĈYcGUpu CY"J-(((3̼Zɓ|VƪE?ADp3'g{'λ~vcQԴJχpuDND>,55U944t%JpY*鷃"{0UdūbnMSv^NHHjX9$$+}`t x^g-[TVl:wN!PEذjP]xuݢ(|ڢEFdsJ77x7o j @93wD(JI|E=Xփ`Z,vbbb zX62ggB=ͱ[NfdNCBxPXbUfGYI)Oga8Va Z~v}ٮ"3f4^oE>8 B#/2V녪ZBn*gdb8β&e`l"MbyZ̠]D#"z)+ҔTSi9(ϑNJ"pc77ZH0 ϷEڦ"oEg))jlS"?^6f |-:,]scdO[6Φ}V`țE>Ye},eMi|ci&Η荄UՓAKnڈu>R%"͡N lܣ"6 lYU,j5$Ta\*ЙL'?!Nq}[MqƂyԶ/Zz:EZѽ'6lK@8A7wO zr"`p{< w"%XO[kB**Wgڳʱ}AF`UD^ k(2~ZG gTRn@g? cǎv1o/$TO֨yYw'z_ONxemүc(zZپjc#^{UTu^]"f7ShL{߫_gv4^|OZ*{Fl3+V-b7Z͞.{u^kڱZ ʜtu1|+XȚ*GgM0ihct"V'rYKꄨ%<,DSMR!G!#tRՖ{_lABdayea;[v%^ErJ[[6fwMJw x^;΀ːWEvRDcm[yPL+ &-|'JI=G`Yߧ/RiՕvRZ~ݳJ;[ ~ّC^f8Gn;`iDq-iEtG dO N`\zDP`(_M;Ir4eƝ o<ۓ=ۇ\R#4cҭ CƳ_yma ,Zi8iV9Ԙfpl"U8!Z [/Q |@1jG曵441ڇ|S>.ȸXje3ª}_y JP\b8*-FSENA 5 y3t z~\f%EyqNl0ogo GDx4jb `/wPD`TM>ޏ__t@o` CT3=YikzFNhHE&F Wkco\!j=BTwEUWg RJЯ#~Y>Tl#t\w sL~۝Cb q5MPͣnfUORZCzBUH*!|F0}xl,X~g8vJGCJHG5:'V+2^ڟ_Ճ/U\ui+肥Z70O"| vʧ{9|UΫxdFDz\ˎ];5,#gjxxRώT™r,]N%(ɡ)UDf^ <Ӆ:7>Ο~f24+B^Q-O=ľ Uy~ّy+ǻg?;KjG6z-ƛ}{81(Ta6֗1#ˎLG¼ U5z|q?1s?eH~͢D5\x{=|G :l.נwWGpPcuic_i+ϙ:QiE|ѷiT^'Xx0oޝK;`ߑ&ё2RVN5TҸbp}W\E<ʷk1{t]]c}B ƫ5*k }V'B7úX9 tHAZҩR=An8@`pli^]a ^DRy;c˼0D#3sd\HYCXE^״9vaJ]eJDN#|&2nQjV>ڕι5+|lu:5@:I3+h2OecwPm|`r9{, 8^k0^b_'jf1ɡ?#' <0{ Xy3xo Ubb8hzctzy:fD #=rFS4D:z ^~&0N&eDǟО"LoёX"v⟳{ }x_DV*='tB1{X_&:8*eV43\4岦P+-?c|0&9}>[bSZħ jeEyhWlELCVG"=O'̋o֞wREOt;,?Mobӊl Do,9E'N}\xNL 7$f7S.ۆOH8qIjD'gUbN|dH?MsLjQH01ڇ+O#?^>Ώk VM(^KD5F '[+> }9tJb^<" uG8y\18P]c@q<[ιG&W.tEby'㋨m¯QMEƬZ(I8 _O[<4)!*$L:z 3Eg?;4JuMRΖaKi߾W=vA `gWם9A?8-f`eꇍWTzuU2geKbJ[ ~t<XG6Տ=4Hy8;bfqa|3/Vo^aRҚuY2-6!q~%fq<2iȼ4d04ng=hkgi“(bn%x=cP}3WB&ho/ 59UC0xZeolݗOZowLWS̼4z'uCP6+ƛl*ԨS黟3|v:A#"wadбb[G )t)D!gb3e8r\%~Y6#Ңo2<]n_'mٗG.NrDxdjJ1"#"5{ܔwmg+EbiuyTZ{6KPJ0m?6% bI#sO%(i|ڶa L wㅯopc"CTPs?6IP/ʠ r3!|=Vg\6uf01ڇ͎v*vӦCkݿů:ۖ4 biK48R3ƏO Ĵ\wÅ*Q|ۙ]n\&_T Nf3WH.39G@&GRYoBuc'R-x>Rd }3LA_⁗v; P\/n:Љ3ed?tC'ߖJ~^5ԓ@:!}I:]-*΀N<OGe5>czwIRVH+eFDeW94_J _>IcSїR3-ZњXUM6@EZḄ";\^Ixue eNii*͝"?Nk"3jxVf\$YbG΄%N,4ß~ByXV'<9Q m[h? X~Li ןqqTԢrrX$g~ Za&66y5 z?%Ff̀R=i~1ƮC47BBz+sTדL*׽;6e*3Jh1F|!j HC_ƳScV`VboQr嵿C'DT0fMVOt2DX$Ы[ot섔' Utl W) ȩ"OP1`T)r V9-j 5 0$4# ں*\̽ v[9A؋߮Jمz'==;U"xjBujHKB QY1wsx829rb/ZzltR&HYǦ*Ek ©ֻ "rJHWGN yJ^$!-l6Q넋VB9:JiJO^]ݸN ,ݤ[:7j/ozfE5v2O7[Lp7l;4,%qCέ .4z꼋chN 4GHnz|r)_7p%r tvW4/6| GG'AF2>6{8 Ը5 GYя||K-;_DybƀBib,]xu(lMvqevLQ\_/L0 g٥Hv IDAT99’;⚤L׍rk T}Wn%Qdt!;EM ;ʱ|] jL02sk t-~_ gG _r8tRD!_ ½!c$$rR!P[؆($ɊB@6Jo 3T\ʔ&w't%;Py = :} P9D63/T[t!X{uv PS& or{ed׌!P+7l%uI-6U/b>^cXDT `qiiHddV} \'A 5 zP['@&%L^>!ĐB!-ao,z*jPލ$B%e3/Dxt{2뷗`q$"WKW ndy 3u% @"@bp:i2DzɓY%?Dio!yuQTLjqv>v*:>RšR!(%&&_f);IT"H) ^A/ܡ1D G0բ?\I'"st^HHHx1//dfe=z]ye`zQ&)]!Ia0())Aee%?P\*a9N-Qdjkk?HMMdv݋_,I﫩Z^u`%vĜ\Z4CCjjE\J1 <C{+Lw@gB~P#HDT 㚚RSS-c[`bE:v^|TWf^#+E|Y+RɓMhF3$$ yt{;O猘 NIo6 )ǗKPt0(KNN>њei2>Tz /=°f^v`j_lսDDo$$$BDkӪӧOB =&gO,0a vU5dOL'lڥ} H$oxb]`~z+zy($''guڵ J3TNVi2[VUjKMDt6.2׉YggEz,Rɴ&W ((hu5 E̯0P%^[ZE=Xփ`C&R-iFẕH'9Ch6NX m,OJJ:f3g*-- UXBܦsȭ[jEZ M nSKZ,Qs#+'aEZk,90i2V%"ړ3SnꕦmoEV$3t'h':\H0-o=P-ң)5XB&[l"z3!!aeKܾtHdr<\ۼioo}:v+r=7kkEGbbּ֦Ë\Oppp K 1^o?cjhʚ"KHHm"ȗGCަ2+TV72^6}n%'ݿJ:qݔT T*~رmP6v  S ۯ0mS(K5?cǎmkb]sm ݻwNQ7888 Description: A collection of testing enhancements and utilities. Including utilities for extracting inline test blocks from package source files. License: GPL-2 Encoding: UTF-8 Language: en-US LazyData: true Imports: assertthat, methods, parsetools, pkgcond, postlogic, purrr, rlang, stringi, testthat, utils Suggests: covr, devtools, withr, rstudioapi, htmltools, shiny, yaml, DT RoxygenNote: 6.1.1 Collate: 'extract_tests.R' 'catch_condition.R' 'inheritance.R' 'new_namespace.R' 'strings.R' 'util-testing.R' 'validity.R' 'coverage.R' URL: https://github.com/RDocTaskForce/testextra BugReports: https://github.com/RDocTaskForce/testextra/issues NeedsCompilation: no Packaged: 2019-12-18 09:12:49 UTC; hornik Author: Andrew Redd [aut, cre] (), R Documentation Task Force [cph] (https://rdoctaskforce.github.io/), R Consortium [fnd] (https://www.r-consortium.org) Repository: CRAN Date/Publication: 2019-12-18 09:15:29 UTC testextra/tests/0000755000175100001440000000000013372405163013461 5ustar hornikuserstestextra/tests/testthat/0000755000175100001440000000000013576367061015333 5ustar hornikuserstestextra/tests/testthat/test-catch_condition.R0000644000175100001440000000213013402317053021537 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `catch_condition.R`') #line 28 "R/catch_condition.R" test_that('catch_condition', {#@testing val <- catch_condition(pkg_message("testing")) expect_is(val, 'condition') expect_is(val, 'message') }) #line 52 "R/catch_condition.R" test_that('catch_all_conditions', {#@testing my_fun <- function(){ message("a message") warning("a warning") pkg_message("a package message", scope="test") pkg_warning("a package warning", scope="test") pkg_error("a package error", scope='test') } conditions <- catch_all_conditions(my_fun()) expect_length(conditions, 3) expect_is(conditions$error, 'test-error') expect_length(conditions$warnings, 2) expect_is(conditions$warnings[[1]], 'simpleWarning') expect_is(conditions$warnings[[2]], 'test-warning') expect_length(conditions$messages, 2) expect_is(conditions$messages[[1]], 'simpleMessage') expect_is(conditions$messages[[2]], 'test-message') }) testextra/tests/testthat/test-new_namespace.R0000644000175100001440000000521413413717622021232 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `new_namespace.R`') #line 48 "R/new_namespace.R" test_that('new_namespace_env', {#@testing ns <- new_namespace_env("test namespace") expect_true(isNamespace(ns)) expect_false(isNamespaceLoaded("test namespace")) }) #line 68 "R/new_namespace.R" test_that('new_pkg_environment', {#@testing ns <- new_pkg_environment() expect_true(isNamespace(ns)) expect_equal(getPackageName(ns), "test package environment") expect_equal(environmentName(ns), "test package environment") expect_false(is_namespace_registered(ns)) if (is_namespace_registered("pkg2")) unregister_namespace(asNamespace("pkg2")) ns2 <- new_pkg_environment("pkg2", register=TRUE) expect_true(isNamespace(ns2)) expect_equal(getPackageName(ns2), "pkg2") expect_equal(environmentName(ns2), "pkg2") expect_true(is_namespace_registered('pkg2')) }) #line 84 "R/new_namespace.R" test_that('Can define classes, generics and methods.', {#@testing Can define classes, generics and methods. ns <- new_pkg_environment("class-test", register=TRUE) expect_true(isNamespace(ns)) expect_equal(getPackageName(ns), "class-test") expect_equal(environmentName(ns), "class-test") expect_true(is_namespace_registered(ns)) cls <- setClass("my-test-class", contains='list', where=ns) expect_is(cls, 'classGeneratorFunction') expect_true(exists(classMetaName(cls@className), ns)) val <- setGeneric( "my_generic", function(object)stop('not implimented') , where = ns ) expect_identical(val, "my_generic") expect_true(exists('my_generic', ns)) val <- setMethod('my_generic', 'my-test-class', function(object){ "horray it works" }, where=ns) expect_identical(val, "my_generic") expect_true(exists(methodsPackageMetaName('T', "my_generic", getPackageName(ns)), ns)) expect_true(exists('my-test-class' , get( methodsPackageMetaName('T', "my_generic", getPackageName(ns)) , ns))) unregister_namespace(ns) expect_false(is_namespace_registered(ns)) expect_false(unregister_namespace(ns)) }) #line 113 "R/new_namespace.R" test_that('can specify imports', {#@testing can specify imports pkg <- new_pkg_environment('test-import', import=c('methods', 'testextra')) expect_true(isNamespace(pkg)) expect_true("testextra" %in% names(pkg$.__NAMESPACE__.$imports)) expect_true(exists("new_pkg_environment", parent.env(pkg), inherits = TRUE)) }) testextra/tests/testthat/test-util-testing.R0000644000175100001440000000104513372730004021044 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `util-testing.R`') #line 14 "R/util-testing.R" test_that('is_valid_regex', {#@testing expect_true(is_valid_regex("^hello world$")) expect_false(is_valid_regex("^hello (world$")) expect_identical( validate_that(is_valid_regex("^hello (world$")) , "invalid regular expression " %<<<% "'^hello (world$', reason 'Missing ')''" ) }) testextra/tests/testthat/test-inheritance.R0000644000175100001440000001050113413703003020675 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `inheritance.R`') #line 41 "R/inheritance.R" test_that('all_inherit', {#@testing l <- list( 'a', 'b', 'c' , 1, 2 , function()"hello world" ) expect_identical( validate_that(all_inherit(l, 'character')) , "`l` has bad elements at 4, 5, and 6" %<<% "which do not inherit from" %<<% dQuote("character") %<<<% '.') expect_identical( validate_that(all_inherit(l, c('character', 'function'))) , "`l` has bad elements at 4 and 5" %<<% "which do not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("function") %<<<% '.') expect_identical( validate_that(all_inherit(l, c('character', 'numeric'))) , "`l` has bad element at 6" %<<% "which does not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("numeric") %<<<% '.' %<<% "It is a" %<<% dQuote("function")) expect_true( all_inherit(list(1L, 2L, 3L), 'integer')) }) #line 71 "R/inheritance.R" test_that('are', {#@testing lst <- list('a', 1L, TRUE) expect_true(all(are(lst, 'ANY'))) expect_identical(are(lst, 'character'), c(T,F,F)) expect_identical(are(lst, 'integer'), c(F,T,F)) expect_identical(are(lst, 'numeric'), c(F,T,F)) }) #line 114 "R/inheritance.R" test_that('all_are_exactly', {#@testing l <- list( 'a', 'b', 'c' , 1, 2) expect_identical( validate_that(all_are_exactly(l, 'character')) , "`l` has bad elements at positions 4 and 5" %<<% "which are not of class" %<<% dQuote("character") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1,2), 'integer', '...')) , "... has bad elements at positions 1 and 2" %<<% "which are not of class" %<<% dQuote("integer") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1L,2L), 'numeric', '...')) , "... has bad elements at positions 1 and 2" %<<% "which are not of class" %<<% dQuote("numeric") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1, 2L), 'numeric', '...')) , "... has bad element at position 2" %<<% "which is not of class" %<<% dQuote("numeric") %<<<% '.') expect_true(all_are_exactly(list(1L, 2L), 'integer')) }) #line 165 "R/inheritance.R" test_that('expect_is_not', {#@testing expect_is_not('a', 'numeric') }) #line 183 "R/inheritance.R" test_that('expect_is_exactly', {#@testing x <- list(1:3) expect_identical(expect_is_exactly(x, 'list'), x) class(x) <- c('class', 'super1', 'super2') expect_is_exactly(x, 'class') expect_is(x, 'super1') expect_error( expect_is_exactly(x, 'super1') , "`x` is a class/super1/super2; should be exactly a `super1`." ) }) #line 207 "R/inheritance.R" test_that('expect_all_inherit', {#@testing expect_true( expect_all_inherit(1:3, 'integer')) l <- list( 'a', 'b', 'c' , 1, 2 , function()"hello world" ) expect_error( expect_all_inherit(l, 'character') , "`l` has bad elements at 4, 5, and 6" %<<% "which do not inherit from" %<<% dQuote("character") %<<<% '.') expect_error( expect_all_inherit(l, c('character', 'function')) , "`l` has bad elements at 4 and 5" %<<% "which do not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("function") %<<<% '.') expect_error( expect_all_inherit(l, c('character', 'numeric')) , "`l` has bad element at 6" %<<% "which does not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("numeric") %<<<% '.' %<<% "It is a" %<<% dQuote("function")) }) testextra/tests/testthat/test-strings.R0000644000175100001440000000232213413703003020077 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `strings.R`') #line 34 "R/strings.R" test_that('is_nonempty_string', {#@testing expect_true(is_nonempty_string("hello world")) expect_false(is_nonempty_string(c("hello", "world"))) expect_false(is_nonempty_string(character(0))) expect_false(is_nonempty_string(NA_character_)) expect_false(is_nonempty_string('')) expect_identical( validate_that(is_nonempty_string(character(0))) , sQuote("character(0)") %<<% .nonempty.string.msg) bad <- NA expect_identical( validate_that(is_nonempty_string(bad)) , sQuote("bad") %<<%.nonempty.string.msg) }) #line 62 "R/strings.R" test_that('is_optional_string', {#@testing expect_true(is_optional_string("hello")) expect_true(is_optional_string(character(0))) expect_false(is_optional_string(NA_character_)) expect_false(is_optional_string('')) expect_false(is_optional_string(letters)) bad <- NA_character_ expect_identical(validate_that(is_optional_string(bad)) , sQuote('bad') %<<% .optional.string.msg) }) testextra/tests/testthat/test-validity.R0000644000175100001440000000245313402253742020250 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `validity.R`') #line 56 "/rdtf/testextra/R/validity.R" test_that('expect_valid', {#@testing gen <- setClass('invalid', list(valid='logical')) setValidity('invalid', function(object) 'This class is always invalid') obj <- gen() expect_false(is_valid(obj)) expect_identical( assertthat::validate_that(is_valid(obj)) , "This class is always invalid") expect_error( expect_valid(obj) , "`obj` is not valid;" %<<% dQuote("This class is always invalid") ) cls <- setClass('test_class', contains='list') setValidity('test_class', function(object)TRUE) obj2 <- cls() expect_true(is_valid(obj2)) expect_silent(expect_valid(obj2)) lst <- list(obj, obj2) expect_identical( are_valid(lst) , structure( c(FALSE, TRUE) , messages = list("This class is always invalid", NULL) ) ) expect_identical( validate_that(all(are_valid(lst))) , "Elements 1 of are_valid(lst) are not true" ) expect_identical(are_valid(list(obj2, obj2)), c(TRUE, TRUE)) }) testextra/tests/testthat/test-extract_tests.R0000644000175100001440000004354413414710231021317 0ustar hornikusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `extract_tests.R`') #line 46 "R/extract_tests.R" test_that('.pkg_base', {#@testing test.pkg.src <- system.file("testExtractionTest", "R", package = "testextra") pkg <- normalizePath( file.path(tempdir(), "testExtractionTest") , "/", mustWork = FALSE) if (dir.exists(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) suppress_messages( package.skeleton("testExtractionTest", path=tempdir() , code_files = list.files(test.pkg.src, full=TRUE) )) expect_identical(.pkg_base(pkg), pkg) expect_identical(.pkg_base(file.path(pkg, "R", fsep = '/')), pkg) expect_identical(.pkg_base(file.path(pkg, "R", "Class.R", fsep = '/')), pkg) unlink(file.path(pkg, "DESCRIPTION", fsep = '/')) expect_null(.pkg_base(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) }) #line 117 "R/extract_tests.R" test_that('.extract_tests_to_file Basic', {#@testing .extract_tests_to_file Basic {'hello_world <- function(){ print("hello world") } if(FALSE){#!@testthat expect_output(hello_world(), "hello world") } f2 <- function(){stop("this does nothing")} if(F){#! @test expect_error(f2()) } if(F){#! example hw() } '}-> text tmp.in <- normalizePath(tempfile("src-" , fileext=".R"), '/', FALSE) tmp.out <- normalizePath(tempfile("test-", fileext=".R"), '/', FALSE) if (!dir.exists(. <- dirname(tmp.in))) dir.create(.) writeLines(text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) expect_true ( file.exists(tmp.out)) expect_equal( lines <- readLines(tmp.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", tmp.in) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", tmp.in) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = tmp.out)) unlink(tmp.out) expect_message( x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE) , "* Extracting tests from file `.*`." ) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", tmp.in) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", tmp.in) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = tmp.out)) val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE, force=FALSE) expect_identical(val, structure(character(0), test.file=tmp.out)) expect_message( val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE, force=FALSE) , " \\+ file `" %<<<% tmp.out %<<<% "` is newer\\. SKIPPING\\." ) val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE, force=TRUE) expect_equal(val, structure(c("hello_world", "f2"), test.file = tmp.out)) unlink(tmp.out) withr::with_dir(dirname(tmp.in), { if (dir.exists('tests')) unlink('tests', recursive = TRUE, force = TRUE) x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , NULL , verbose=FALSE) file.out <- file.path('.', "test-" %<<<% basename(tmp.in), fsep='/') expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2") , test.file = file.out)) unlink(file.out) }) withr::with_dir(dirname(tmp.in), { if (!dir.exists('tests')) dir.create('tests') else if ( dir.exists('tests/testthat')) unlink('tests/testthat', TRUE, TRUE) expect_message({ x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , NULL , verbose=TRUE) }, " \\+ `test.dir` not provided. Setting to `.*`") file.out <- "./tests/test-" %<<<% basename(tmp.in) expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = file.out)) unlink(file.out) unlink("tests", force = TRUE) }) withr::with_dir(dirname(tmp.in), { if (!dir.exists('tests/testthat')) dir.create('tests/testthat', recursive = TRUE) tryCatch({ expect_true(file.exists(basename(tmp.in))) expect_message({ x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , test.dir = NULL , verbose=TRUE) }, " \\+ Writting extracted tests to `.*`.") file.out <- "./tests/testthat/test-" %<<<% basename(tmp.in) expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = file.out)) }, finally = unlink(file.path(tempdir(), "tests"), TRUE, TRUE)) }) expect_false(dir.exists(file.path(tempdir(), "tests"))) unlink(tmp.in) }) #line 280 "R/extract_tests.R" test_that('.extract_tests_to_file setClass', {#@testing .extract_tests_to_file setClass {' setClass("Test-Class") if(FALSE){#!@test expect_true(TRUE) expect_is(getClass("Test-Class"), "classRepresentation") } '}-> class.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(class.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('setClass(\"Test-Class\", ...)', {#!@test" , " expect_true(TRUE)" , " expect_is(getClass(\"Test-Class\"), \"classRepresentation\")" , "})" ) ) expect_equal(x, structure("setClass(\"Test-Class\", ...)", test.file = tmp.out)) unlink(tmp.in) unlink(tmp.out) }) #line 314 "R/extract_tests.R" test_that('.extract_tests_to_file setMethod', {#@testing .extract_tests_to_file setMethod ' setMethod("show", "Test-Class", function(x){cat("hi")}) if(FALSE){#!@test expect_true(TRUE) } '-> method.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(method.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('show,Test-Class-method', {#!@test" , " expect_true(TRUE)" , "})" ) ) expect_equal(x, structure("show,Test-Class-method", test.file = tmp.out)) unlink(tmp.in) unlink(tmp.out) }) #line 345 "R/extract_tests.R" test_that('.extract_tests_to_file setGeneric', {#@testing .extract_tests_to_file setGeneric ' setGeneric("yolo", yolo::yolo) if(FALSE){#!@test expect_true(TRUE) } '-> generic.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(generic.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('setGeneric(\"yolo\", ...)', {#!@test" , " expect_true(TRUE)" , "})" ) ) expect_equal(x, structure("setGeneric(\"yolo\", ...)", test.file = tmp.out)) }) #line 373 "R/extract_tests.R" test_that('.extract_tests_to_file no test blocks', {#@testing .extract_tests_to_file no test blocks 'hello_world <- function(){ print("hello world") } f2 <- function(){stop("this does nothing")} if(F){#! example hw() } '-> text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(text, tmp.in) expect_message( x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE) , class = "testextra-message") expect_identical(x, character()) expect_false (file.exists(tmp.out)) }) #line 497 "R/extract_tests.R" test_that('extract_tests', {#@testing tmp.dir <- normalizePath(tempdir(), '/', TRUE) if (!dir.exists(tmp.dir)) dir.create(tmp.dir) if (dir.exists(. <- file.path(tmp.dir, "testExtractionTest"))) unlink(., recursive = TRUE, force = TRUE) package.skeleton("testExtractionTest", path=tmp.dir, force=TRUE , code_files = list.files(system.file("testExtractionTest", "R", package='testextra'), full=TRUE) ) pkg <- file.path(tmp.dir, "testExtractionTest", fsep='/') expect_warning( result <- extract_tests(pkg) , "testthat not found in suggests. `extract_tests` assumes a testthat infrastructure.") test.dir <- file.path(tmp.dir, 'testExtractionTest', 'tests', 'testthat', fsep='/') expected <- structure( list( structure(c( "setClass(\"Test-Class\", ...)" , "show,Test-Class-method" , "setGeneric(\"yolo\", ...)" ) , test.file = file.path(test.dir, 'test-Class.R', fsep='/') ) , structure("hello_world" , test.file = file.path(test.dir, 'test-function.R', fsep='/') ) ) , names = file.path('R', c('Class.R', 'function.R')) ) test.dir <- normalizePath(file.path(pkg, "tests", "testthat"), '/', FALSE) expect_identical(list.files(test.dir), c('test-Class.R', 'test-function.R')) file <- file.path(test.dir, 'test-Class.R') expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `Class.R`')" , "#line 4 \"R/Class.R\"" ) ) expect_equal( result, expected) expect_true(dir.exists(file.path(pkg, "tests", "testthat"))) expect_true(file.exists(file.path(pkg, "tests", "testthat", "test-Class.R"))) expect_true(file.exists(file.path(pkg, "tests", "testthat", "test-function.R"))) description <- as.data.frame(read.dcf(file.path(pkg, 'DESCRIPTION'))) description$Suggests <- collapse(c('testthat', 'testextra'), ", ") write.dcf(description, file=file.path(pkg, 'DESCRIPTION')) unlink(sapply(expected, attr, 'test.file')) expect_silent(result <- extract_tests(pkg, full.path = TRUE)) expected <- structure( expected , names = file.path(pkg, 'R', c('Class.R', 'function.R'), fsep ="/")) expect_identical(result, expected) file <- file.path(test.dir, 'test-Class.R') from <- normalizePath(file.path(pkg, "R", "Class.R"), '/', FALSE) expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `" %<<<% from %<<<% "`')" , "#line 4 \"" %<<<% from %<<<%"\"" ) ) unlink(sapply(expected, attr, 'test.file')) expect_silent(result <- extract_tests(pkg, full.path = FALSE)) expected <- structure( expected , names = c('Class.R', 'function.R') ) expect_identical(result, expected) file <- file.path(test.dir, 'test-Class.R') from <- normalizePath(file.path(pkg, "R", "Class.R"), '/', FALSE) expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `" %<<<% basename(from) %<<<% "`')" , "#line 4 \"" %<<<% basename(from) %<<<%"\"" ) ) unlink(pkg, recursive=TRUE, force = TRUE) }) #line 581 "R/extract_tests.R" test_that('extract_tests', {#@testing pkg <- file.path(tempdir(), "testExtractionTest") if (dir.exists(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) package.skeleton("testExtractionTest", path=tempdir() , code_files = list.files(system.file("testExtractionTest", "R", package='testextra'), full=TRUE) ) test.dir <- normalizePath(file.path(pkg, "tests", "testthat"), '/', mustWork = FALSE) description <- as.data.frame(read.dcf(file.path(pkg, 'DESCRIPTION'))) description$Suggests <- collapse(c('testthat', 'testextra'), ", ") write.dcf(description, file=file.path(pkg, 'DESCRIPTION')) expect_identical(list.files(test.dir, full.names = TRUE),character()) result <- extract_tests(pkg, filter='Class', full.path = FALSE) expect_length(result, 1) expect_length(result[[1]], 3) expect_equal( structure(result[[1]], test.file=NULL) , c( 'setClass("Test-Class", ...)' , 'show,Test-Class-method' , 'setGeneric("yolo", ...)' ) ) expect_equal( normalizePath(attr(result[[1]], "test.file")) , normalizePath(file.path(test.dir, 'test-Class.R', fsep='/')) ) expect_true(dir.exists(test.dir)) expect_identical( list.files(test.dir, full.names = FALSE) , 'test-Class.R' ) expect_error(extract_tests(pkg, filter='bad filter', full.path = FALSE) , "Filtered to no files to extract from\\.") unlink(pkg, recursive = TRUE, force=TRUE) }) testextra/tests/testthat.R0000644000175100001440000000043613372405163015447 0ustar hornikusers# This file was created by `documentation::extract_tests` on 2018-11-12 16:19:15. # Once present, this file will not be overwritten and changes will persist. # To recreate the default version of this file delete and rerun `extract_tests`. library(testthat) test_check("testextra") testextra/R/0000755000175100001440000000000013402562406012516 5ustar hornikuserstestextra/R/strings.R0000644000175100001440000000472013407455163014343 0ustar hornikusers#' @name string-tests #' @title Tests for strings #' #' @param x a character vector/string. NULL .nonempty.string.msg <- "does not conform to a non-empty string" %<<% "(a character vector of length 1 without" %<<% "without missing or empty values)." #' @describeIn string-tests Test that a character is both a string (character vector of length one) #' and that it is non-empty, has at least one character and is not missing. #' #' @examples #' # TRUE #' is_nonempty_string("hello") #' #' # All FALSE #' x <- c("hello", "world") #' is_nonempty_string(x) #' is_nonempty_string(NA_character_) #' is_nonempty_string(character(0)) #' is_nonempty_string(NULL) #' is_nonempty_string(12345) is_nonempty_string <- structure(function(x){ is.character(x) && length(x) == 1L && !is.na(x) && nchar(x) > 0L }, fail = function(call, env){ sQuote(deparse(call$x)) %<<% .nonempty.string.msg }) if(FALSE){#@testing expect_true(is_nonempty_string("hello world")) expect_false(is_nonempty_string(c("hello", "world"))) expect_false(is_nonempty_string(character(0))) expect_false(is_nonempty_string(NA_character_)) expect_false(is_nonempty_string('')) expect_identical( validate_that(is_nonempty_string(character(0))) , sQuote("character(0)") %<<% .nonempty.string.msg) bad <- NA expect_identical( validate_that(is_nonempty_string(bad)) , sQuote("bad") %<<%.nonempty.string.msg) } .optional.string.msg <- "does not conform to an optional string" %<<% "(a character vector of length 0 or 1," %<<% "without missing or empty values)." #' @describeIn string-tests Check for an optional string: must be a character, not missing, #' a vector of either length 0 or 1, and if provided must not be empty (""). is_optional_string <- structure(function(x){ is.character(x) && length(x) <= 1L && !any(is.na(x)) && !any(nchar(x) == 0L) }, fail = function(call, env){ sQuote(deparse(call$x)) %<<% .optional.string.msg }) if(FALSE){#@testing expect_true(is_optional_string("hello")) expect_true(is_optional_string(character(0))) expect_false(is_optional_string(NA_character_)) expect_false(is_optional_string('')) expect_false(is_optional_string(letters)) bad <- NA_character_ expect_identical(validate_that(is_optional_string(bad)) , sQuote('bad') %<<% .optional.string.msg) } testextra/R/util-testing.R0000644000175100001440000000127213372363563015304 0ustar hornikusers#' Extract class as a single string. #' #' @param x any object. class0 <- function(x)collapse(class(x), '/') #' Check if a regular expression is valid. #' #' @param pattern the regular expression pattern to test. is_valid_regex <- function(pattern){ tryCatch( grepl(pattern, '') || TRUE , error= function(e)structure(FALSE, msg=e$message)) } if(FALSE){#@testing expect_true(is_valid_regex("^hello world$")) expect_false(is_valid_regex("^hello (world$")) expect_identical( validate_that(is_valid_regex("^hello (world$")) , "invalid regular expression " %<<<% "'^hello (world$', reason 'Missing ')''" ) } testextra/R/new_namespace.R0000644000175100001440000001264113413717241015453 0ustar hornikusersglobalVariables(c('getNamespaceRegistry', 'unregisterNamespace')) #' @name namespaces #' @title Create namespace environments #' #' @description #' Create and manipulate namespace and test package environments. #' #' @param name The name of the environment #' @param path An optional path. #' @param import Package to include in the imports. #' @inheritDotParams new_namespace_env #' @param register Should the package namespace be registered? #' @param ns a namespace environment or a character name of a namespace. #' @example inst/examples/example-namespace.R NULL #' @describeIn namespaces Create a new namespace environment new_namespace_env <- function( name , path = file.path(tempdir()) , import = 'methods' ){ assert_that(!isNamespaceLoaded(name)) new_sub_env <- function(part, parent=baseenv()){ structure( new.env(parent=parent, hash=TRUE) , name = part %<<<% ':' %<<<% name ) } if (!dir.exists(path)) dir.create(path) # nocov path <- normalizePath(path, "/", TRUE) imports <- new_sub_env('imports', .BaseNamespaceEnv) ns <- new.env(TRUE, imports) ns$.__NAMESPACE__. <- new.env(parent = baseenv()) ns$.__NAMESPACE__.$spec <- c(name = name, version = "0.0.0") setNamespaceInfo(ns, "exports" , new_sub_env('exports')) setNamespaceInfo(ns, "lazydata" , new_sub_env('lazydata')) setNamespaceInfo(ns, "imports" , list(base = TRUE)) setNamespaceInfo(ns, "path" , path) setNamespaceInfo(ns, "dynlibs" , NULL) setNamespaceInfo(ns, "S3methods", matrix(NA_character_, 0L, 3L)) ns$.__S3MethodsTable__. <- new.env(hash = TRUE, parent = baseenv()) for (i in import) namespaceImport(self=ns, i, from=i) ns } if(FALSE){#@testing ns <- new_namespace_env("test namespace") expect_true(isNamespace(ns)) expect_false(isNamespaceLoaded("test namespace")) } #' @describeIn namespaces Create a package environment. #' All package environments are namespaces but not all #' namespaces qualify as package environments. new_pkg_environment <- function( name = "test package environment" , ... , register = FALSE ){ env <- new_namespace_env(name, ...) setPackageName(name, env) if (register) register_namespace(env) return(env) } if(FALSE){#@testing ns <- new_pkg_environment() expect_true(isNamespace(ns)) expect_equal(getPackageName(ns), "test package environment") expect_equal(environmentName(ns), "test package environment") expect_false(is_namespace_registered(ns)) if (is_namespace_registered("pkg2")) unregister_namespace(asNamespace("pkg2")) ns2 <- new_pkg_environment("pkg2", register=TRUE) expect_true(isNamespace(ns2)) expect_equal(getPackageName(ns2), "pkg2") expect_equal(environmentName(ns2), "pkg2") expect_true(is_namespace_registered('pkg2')) } if(FALSE){#@testing Can define classes, generics and methods. ns <- new_pkg_environment("class-test", register=TRUE) expect_true(isNamespace(ns)) expect_equal(getPackageName(ns), "class-test") expect_equal(environmentName(ns), "class-test") expect_true(is_namespace_registered(ns)) cls <- setClass("my-test-class", contains='list', where=ns) expect_is(cls, 'classGeneratorFunction') expect_true(exists(classMetaName(cls@className), ns)) val <- setGeneric( "my_generic", function(object)stop('not implimented') , where = ns ) expect_identical(val, "my_generic") expect_true(exists('my_generic', ns)) val <- setMethod('my_generic', 'my-test-class', function(object){ "horray it works" }, where=ns) expect_identical(val, "my_generic") expect_true(exists(methodsPackageMetaName('T', "my_generic", getPackageName(ns)), ns)) expect_true(exists('my-test-class' , get( methodsPackageMetaName('T', "my_generic", getPackageName(ns)) , ns))) unregister_namespace(ns) expect_false(is_namespace_registered(ns)) expect_false(unregister_namespace(ns)) } if(FALSE){#@testing can specify imports pkg <- new_pkg_environment('test-import', import=c('methods', 'testextra')) expect_true(isNamespace(pkg)) expect_true("testextra" %in% names(pkg$.__NAMESPACE__.$imports)) expect_true(exists("new_pkg_environment", parent.env(pkg), inherits = TRUE)) } .ns.registry <- function(){ (get(".Internal", envir = baseenv(), mode = "function"))(getNamespaceRegistry()) } #' @describeIn namespaces Register a namespace register_namespace <- function(ns){ assert_that( isNamespace(ns) , is_nonempty_string(name <- environmentName(ns)) , !is_namespace_registered(name) ) assign(name, ns, .ns.registry()) invisible(ns) } #' @describeIn namespaces Remove a namespace from the registry unregister_namespace <- function(ns){ assert_that( isNamespace(ns) , is_nonempty_string(name <- environmentName(ns)) ) if (is_namespace_registered(name)) (get(".Internal", envir = baseenv(), mode = "function"))(unregisterNamespace(name)) else FALSE } #' @describeIn namespaces Check if a namespace is registered is_namespace_registered <- function(ns){ if (is.environment(ns) && assert_that(isNamespace(ns))) ns <- environmentName(ns) else assert_that(is.character(ns) , msg = "ns must be a name string or a namespace environment" ) ns %in% names(.ns.registry()) } testextra/R/inheritance.R0000644000175100001440000002125513411530107015130 0ustar hornikusers # Tests -------- #' @name class-tests #' @title Enhanced Class Tests #' @description #' These tests allow for mapped and enhanced tests regarding class. #' #' @inheritParams testthat::expect_is #' @param object An object to test #' @param lst A list of objects to test #' @param class The class object is to be, or classes it is allowed to be. #' #' @family class #' @example inst/examples/example-class-tests.R NULL #' @describeIn class-tests Check if all elements of a list are or inherit from the given class. #' Uses [base::inherits()] to check inheritance. all_inherit <- function(lst, class, label=NULL){ act <- testthat::quasi_label(rlang::enquo(lst), label) stopifnot( is.character(class) || is.null(class) ) if (all(. <- purrr::map_lgl(lst, inherits, what=class, which=FALSE))) return(TRUE) msg <- if (sum(!.) > 1L) { ._("%s has bad elements at %s which do not inherit from %s." , act$lab , comma_list(which(!.)) , comma_list(dQuote(class), sep2 = ' or ', sep.last = ' or ') ) } else { bad.class <- purrr::map_chr(lst[!.], class0) ._("%s has bad element at %s which does not inherit from %s. It is a %s" , act$lab , comma_list(which(!.)) , comma_list(dQuote(class), sep2 = ' or ', sep.last = ' or ') , dQuote(bad.class) ) } return(structure(FALSE, msg=msg, bad.elements = which(!.))) } if(FALSE){#@testing l <- list( 'a', 'b', 'c' , 1, 2 , function()"hello world" ) expect_identical( validate_that(all_inherit(l, 'character')) , "`l` has bad elements at 4, 5, and 6" %<<% "which do not inherit from" %<<% dQuote("character") %<<<% '.') expect_identical( validate_that(all_inherit(l, c('character', 'function'))) , "`l` has bad elements at 4 and 5" %<<% "which do not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("function") %<<<% '.') expect_identical( validate_that(all_inherit(l, c('character', 'numeric'))) , "`l` has bad element at 6" %<<% "which does not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("numeric") %<<<% '.' %<<% "It is a" %<<% dQuote("function")) expect_true( all_inherit(list(1L, 2L, 3L), 'integer')) } #' @describeIn class-tests [methods::is] mapped over a vector. #' Similar to `all_inherit` but uses [methods::is()] for test. #' This manifests in S4 Virtual classes such as the 'ANY' class are <- function(lst, class){ purrr::map_lgl(lst, is, class) } if(FALSE){#@testing lst <- list('a', 1L, TRUE) expect_true(all(are(lst, 'ANY'))) expect_identical(are(lst, 'character'), c(T,F,F)) expect_identical(are(lst, 'integer'), c(F,T,F)) expect_identical(are(lst, 'numeric'), c(F,T,F)) } #' @describeIn class-tests Test that an object is exactly a class; excludes inheritance. is_exactly <- function(object, class){any(inherits(object, what=class, which=TRUE)==1)} if(FALSE){ x <- Rd_text("text") expect_true(is_exactly(x, 'Rd_TEXT')) expect_true(is_exactly(x, c('Rd_RCODE', 'Rd_TEXT'))) expect_false(is_exactly(Rd(x), c('Rd_RCODE', 'Rd_TEXT'))) docs <- function_documentation() expect_true(is_exactly(docs, 'function-Documentation')) expect_false(is_exactly(docs, 'Documentation')) } #' @describeIn class-tests Version of `is_exactly` for all elements of a list. all_are_exactly <- function(lst, class, label=NULL){ act <- testthat::quasi_label(rlang::enquo(lst), label) stopifnot( is.string(class) ) if (all(. <- purrr::map_lgl(lst, is_exactly, class=class))) return(TRUE) bad.class <- purrr::map_chr(lst[!.], class0) msg <- if (sum(!.) > 1L){ ._("%s has bad elements at positions %s which are not of class %s." , act$lab , comma_list(which(!.)) , dQuote(class) )} else { ._("%s has bad element at position %s which is not of class %s." , act$lab , which(!.) , dQuote(class) )} return(structure(FALSE, msg=msg)) } if(FALSE){#@testing l <- list( 'a', 'b', 'c' , 1, 2) expect_identical( validate_that(all_are_exactly(l, 'character')) , "`l` has bad elements at positions 4 and 5" %<<% "which are not of class" %<<% dQuote("character") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1,2), 'integer', '...')) , "... has bad elements at positions 1 and 2" %<<% "which are not of class" %<<% dQuote("integer") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1L,2L), 'numeric', '...')) , "... has bad elements at positions 1 and 2" %<<% "which are not of class" %<<% dQuote("numeric") %<<<% '.') expect_identical( validate_that(all_are_exactly(list(1, 2L), 'numeric', '...')) , "... has bad element at position 2" %<<% "which is not of class" %<<% dQuote("numeric") %<<<% '.') expect_true(all_are_exactly(list(1L, 2L), 'integer')) } # Expectations ------ #' @name class-expectations #' @title Class Expectations #' @description #' These extend the [testthat::expect_is] to have finer grain tests. #' #' @inheritParams testthat::expect_is #' @param object the object in question. #' @param class the expected class object is to be. #' #' @family class #' @example inst/examples/example-class-expectations.R NULL #' @describeIn class-expectations test that an object does **not** inherit from a class. expect_is_not <- function (object, class, info = NULL, label = NULL){ stopifnot(is.character(class)) act <- testthat::quasi_label(rlang::enquo(object), label) act$class <- exp_lab <- paste(class, collapse = "/") testthat::expect( Negate(is)(act$val, class) , sprintf("%s is a %s; should not inherit from `%s`." , act$lab, act$class, exp_lab) , info = info) invisible(act$val) } if(FALSE){#@testing expect_is_not('a', 'numeric') } #' @describeIn class-expectations test that an object is exactly a specific class #' and not a child class. expect_is_exactly <- function (object, class, info = NULL, label = NULL){ stopifnot(is.character(class)) act <- testthat::quasi_label(rlang::enquo(object), label) act$class <- collapse(class(object), "/") exp_lab <- comma_list(class, sep2 = ' or ', sep.last = ', or a') testthat::expect( is_exactly(act$val, class) , sprintf("%s is a %s; should be exactly a `%s`." , act$lab, act$class, exp_lab) , info = info) invisible(act$val) } if(FALSE){#@testing x <- list(1:3) expect_identical(expect_is_exactly(x, 'list'), x) class(x) <- c('class', 'super1', 'super2') expect_is_exactly(x, 'class') expect_is(x, 'super1') expect_error( expect_is_exactly(x, 'super1') , "`x` is a class/super1/super2; should be exactly a `super1`." ) } #' @describeIn class-expectations test that all elements of a list inherit a given class. expect_all_inherit <- function (object, class, info = NULL, label = NULL) { act <- testthat::quasi_label(rlang::enquo(object), label) test <- all_inherit(object, class, label=act$lab) testthat::expect( isTRUE(test) , attr(test, 'msg') , info = info) invisible(test) } if(FALSE){#@testing expect_true( expect_all_inherit(1:3, 'integer')) l <- list( 'a', 'b', 'c' , 1, 2 , function()"hello world" ) expect_error( expect_all_inherit(l, 'character') , "`l` has bad elements at 4, 5, and 6" %<<% "which do not inherit from" %<<% dQuote("character") %<<<% '.') expect_error( expect_all_inherit(l, c('character', 'function')) , "`l` has bad elements at 4 and 5" %<<% "which do not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("function") %<<<% '.') expect_error( expect_all_inherit(l, c('character', 'numeric')) , "`l` has bad element at 6" %<<% "which does not inherit from" %<<% dQuote("character") %<<% 'or' %<<% dQuote("numeric") %<<<% '.' %<<% "It is a" %<<% dQuote("function")) } testextra/R/validity.R0000644000175100001440000000545213402253734014475 0ustar hornikusers# Validity Tests ------ #' @name validity-tests #' @title Alternate check for validity #' @description #' These functions will test if an object is valid #' returning a value appropriate to use in [assertthat::validate_that()], #' [assertthat::assert_that()], or [assertthat::see_if()]. #' #' @inheritParams class-tests #' @inheritParams methods::validObject #' @inheritParams base::sapply #' @param object an S4 object to test for validity #' @param lst a list of S4 objects to test for validity. #' @family validity-tests NULL #' @describeIn validity-tests Check if an object is valid. is_valid <- function(object, complete=FALSE){ valid <- validObject(object, test=TRUE, complete=complete) if(isTRUE(valid)) return(TRUE) else return(structure(FALSE, msg=valid)) } #' @describeIn validity-tests Check if each element in a list is valid. are_valid <- function(lst, complete=FALSE){ valid <- lapply(lst, is_valid, complete=complete) if (all(. <- sapply(valid, isTRUE))) return(.) messages <- sapply(valid, attr, 'msg') structure(., messages=messages) } # Expectations ---------------------- #' Expect an S4 object is valid #' #' Similar to [is_valid()] except designed to work in the #' [testthat::test_that()] framework. #' #' @inheritParams validity-tests #' @inheritParams testthat::expect_is #' @family validity-tests expect_valid <- function (object, complete=FALSE, info=NULL, label=NULL){ act <- testthat::quasi_label(rlang::enquo(object), label) is.valid <- validObject(object, test=TRUE, complete=complete) testthat::expect(isTRUE(is.valid) , ._("%s is not valid; %s", act$lab, dQuote(is.valid)) , info=info ) } if(FALSE){#@testing gen <- setClass('invalid', list(valid='logical')) setValidity('invalid', function(object) 'This class is always invalid') obj <- gen() expect_false(is_valid(obj)) expect_identical( assertthat::validate_that(is_valid(obj)) , "This class is always invalid") expect_error( expect_valid(obj) , "`obj` is not valid;" %<<% dQuote("This class is always invalid") ) cls <- setClass('test_class', contains='list') setValidity('test_class', function(object)TRUE) obj2 <- cls() expect_true(is_valid(obj2)) expect_silent(expect_valid(obj2)) lst <- list(obj, obj2) expect_identical( are_valid(lst) , structure( c(FALSE, TRUE) , messages = list("This class is always invalid", NULL) ) ) expect_identical( validate_that(all(are_valid(lst))) , "Elements 1 of are_valid(lst) are not true" ) expect_identical(are_valid(list(obj2, obj2)), c(TRUE, TRUE)) } testextra/R/extract_tests.R0000644000175100001440000007211713414710164015544 0ustar hornikusers# extract_tests.R ################################################################ # This file is part of the R package `documentation`. # # # # Copyright 2017 Andrew Redd # # Date: 2017-06-09 # # # # DESCRIPTION # # =========== # # Extract blocks for testing. # # # # LICENSE # # ======== # # The R package `documentation` is free software: # # you can redistribute it and/or modify it under the # # terms of the GNU General Public License as published by the Free Software # # Foundation, either version 3 of the License, or (at your option) any later # # version. # # # # This software is distributed in the hope that it will be useful, but WITHOUT # # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS # # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. # # # # You should have received a copy of the GNU General Public License along with # # this program. If not, see http://www.gnu.org/licenses/. # # # ################################################################################## makeActiveBinding( '.tests.head.lines', function(){ include.time <- getOption("testextra::include_extraction_time", FALSE) c( ._("#! This file was automatically produced by the testextra package.") , if(include.time) ._("#! Extracted on %s", Sys.time()) , ._("#! Changes will be overwritten.") , '' ) }, environment()) .pkg_base <- function(path){ if (grepl("\\.(R|r)$", path)) path <- dirname(path) while ( nchar(path) > 0 && basename(path) %in% c('R', 'man', 'tests', 'testthat') && !file.exists(file.path(path, 'DESCRIPTION')) ) path <- dirname(path) if (file.exists(file.path(path, 'DESCRIPTION'))) return(path) } if(FALSE){#@testing test.pkg.src <- system.file("testExtractionTest", "R", package = "testextra") pkg <- normalizePath( file.path(tempdir(), "testExtractionTest") , "/", mustWork = FALSE) if (dir.exists(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) suppress_messages( package.skeleton("testExtractionTest", path=tempdir() , code_files = list.files(test.pkg.src, full=TRUE) )) expect_identical(.pkg_base(pkg), pkg) expect_identical(.pkg_base(file.path(pkg, "R", fsep = '/')), pkg) expect_identical(.pkg_base(file.path(pkg, "R", "Class.R", fsep = '/')), pkg) unlink(file.path(pkg, "DESCRIPTION", fsep = '/')) expect_null(.pkg_base(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) } #@internal .extract_tests_to_file <- function( file #< file to extract tests from , file.out = NULL #< file to write tests to, if provided must be fully specified, ie. `dir` will be ignored. , test.dir = NULL #< directory where to store extracted blocks. , verbose = getOption('verbose', FALSE) #< Show progress messages? , full.path = FALSE , force = FALSE #< Force extraction ){ pkg_message(._("* Extracting tests from file `%s`.\n", file)) %if% verbose if (is.null(file.out)){ if (is.null(test.dir)){ test.dir <- .pkg_base(file) if (is.null(test.dir)) test.dir <- '.' if (file.exists(. <- file.path(test.dir, "tests" ))) test.dir <- . if (file.exists(. <- file.path(test.dir, "testthat"))) test.dir <- . if (verbose) message(" + `test.dir` not provided. Setting to `", test.dir, "`") } file.out <- file.path(test.dir, sprintf("test-%s", basename(file))) } if (!force && file.exists(file.out) && file.mtime(file) < file.mtime(file.out)){ pkg_message(._(" + file `%s` is newer. SKIPPING.\n", file.out)) %if% verbose return(invisible(structure(character(0), test.file=file.out))) } pkg_message(._(" + Writting extracted tests to `%s`.", file.out)) %if% verbose #! Extract `if(F){#! @TESTTHAT }` blocks from file content <- parsetools::extract_test_blocks(file) if (length(content)==0){ pkg_message(._(" + No testing blocks found in `%s`.", file)) %if% verbose return(invisible(character(0))) } context.line <- sprintf("context('tests extracted from file `%s`')" , if (full.path) file else basename(file)) cat( .tests.head.lines, context.line, content, file=file.out, sep='\n', append=FALSE ) #! testing blocks can be placed inside the same files as the source #! for the functions. Wrap the lines in curly braces and place #! `if(FALSE)` before the opening brace, to denote that the code #! should not be run when sourced, such as when building a package. #! The `FALSE` may be abbreviated as `F`, but those are the only #! two acceptable options. Also required is a documentation comment with a #! tag denoting that the block is for testing, #! either `@@testthat`, `@@testing`, or simply `@@test` are acceptable. #! The comment must be a documentation comment, regular comments are #! ignored, and the taging comment must be the first element in the block. #! return(structure(attr(content, 'test.names'), test.file=file.out)) } if(FALSE){#@testing .extract_tests_to_file Basic {'hello_world <- function(){ print("hello world") } if(FALSE){#!@testthat expect_output(hello_world(), "hello world") } f2 <- function(){stop("this does nothing")} if(F){#! @test expect_error(f2()) } if(F){#! example hw() } '}-> text tmp.in <- normalizePath(tempfile("src-" , fileext=".R"), '/', FALSE) tmp.out <- normalizePath(tempfile("test-", fileext=".R"), '/', FALSE) if (!dir.exists(. <- dirname(tmp.in))) dir.create(.) writeLines(text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) expect_true ( file.exists(tmp.out)) expect_equal( lines <- readLines(tmp.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", tmp.in) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", tmp.in) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = tmp.out)) unlink(tmp.out) expect_message( x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE) , "* Extracting tests from file `.*`." ) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", tmp.in) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", tmp.in) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = tmp.out)) val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE, force=FALSE) expect_identical(val, structure(character(0), test.file=tmp.out)) expect_message( val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE, force=FALSE) , " \\+ file `" %<<<% tmp.out %<<<% "` is newer\\. SKIPPING\\." ) val <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE, force=TRUE) expect_equal(val, structure(c("hello_world", "f2"), test.file = tmp.out)) unlink(tmp.out) withr::with_dir(dirname(tmp.in), { if (dir.exists('tests')) unlink('tests', recursive = TRUE, force = TRUE) x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , NULL , verbose=FALSE) file.out <- file.path('.', "test-" %<<<% basename(tmp.in), fsep='/') expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2") , test.file = file.out)) unlink(file.out) }) withr::with_dir(dirname(tmp.in), { if (!dir.exists('tests')) dir.create('tests') else if ( dir.exists('tests/testthat')) unlink('tests/testthat', TRUE, TRUE) expect_message({ x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , NULL , verbose=TRUE) }, " \\+ `test.dir` not provided. Setting to `.*`") file.out <- "./tests/test-" %<<<% basename(tmp.in) expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = file.out)) unlink(file.out) unlink("tests", force = TRUE) }) withr::with_dir(dirname(tmp.in), { if (!dir.exists('tests/testthat')) dir.create('tests/testthat', recursive = TRUE) tryCatch({ expect_true(file.exists(basename(tmp.in))) expect_message({ x <- .extract_tests_to_file( file = basename(tmp.in) , file.out = NULL , test.dir = NULL , verbose=TRUE) }, " \\+ Writting extracted tests to `.*`.") file.out <- "./tests/testthat/test-" %<<<% basename(tmp.in) expect_true(file.exists(file.out)) expect_equal( lines <- readLines(file.out) , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 4 \"%s\"", basename(tmp.in)) , "test_that('hello_world', {#!@testthat" , " expect_output(hello_world(), \"hello world\")" , "})" , sprintf("#line 9 \"%s\"", basename(tmp.in)) , "test_that('f2', {#! @test" , " expect_error(f2())" , "})" )) expect_equal(x, structure(c("hello_world", "f2"), test.file = file.out)) }, finally = unlink(file.path(tempdir(), "tests"), TRUE, TRUE)) }) expect_false(dir.exists(file.path(tempdir(), "tests"))) unlink(tmp.in) } if(FALSE){#@testing .extract_tests_to_file setClass {' setClass("Test-Class") if(FALSE){#!@test expect_true(TRUE) expect_is(getClass("Test-Class"), "classRepresentation") } '}-> class.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(class.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('setClass(\"Test-Class\", ...)', {#!@test" , " expect_true(TRUE)" , " expect_is(getClass(\"Test-Class\"), \"classRepresentation\")" , "})" ) ) expect_equal(x, structure("setClass(\"Test-Class\", ...)", test.file = tmp.out)) unlink(tmp.in) unlink(tmp.out) } if(FALSE){#@testing .extract_tests_to_file setMethod ' setMethod("show", "Test-Class", function(x){cat("hi")}) if(FALSE){#!@test expect_true(TRUE) } '-> method.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(method.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('show,Test-Class-method', {#!@test" , " expect_true(TRUE)" , "})" ) ) expect_equal(x, structure("show,Test-Class-method", test.file = tmp.out)) unlink(tmp.in) unlink(tmp.out) } if(FALSE){#@testing .extract_tests_to_file setGeneric ' setGeneric("yolo", yolo::yolo) if(FALSE){#!@test expect_true(TRUE) } '-> generic.text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(generic.text, tmp.in) x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=FALSE) lines <- readLines(tmp.out) expect_true (file.exists(tmp.out)) expect_equal( lines , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , sprintf("context('tests extracted from file `%s`')", basename(tmp.in)) , sprintf("#line 3 \"%s\"", tmp.in) , "test_that('setGeneric(\"yolo\", ...)', {#!@test" , " expect_true(TRUE)" , "})" ) ) expect_equal(x, structure("setGeneric(\"yolo\", ...)", test.file = tmp.out)) } if(FALSE){#@testing .extract_tests_to_file no test blocks 'hello_world <- function(){ print("hello world") } f2 <- function(){stop("this does nothing")} if(F){#! example hw() } '-> text tmp.in <- tempfile("src-" , fileext=".R") tmp.out <- tempfile("test-", fileext=".R") writeLines(text, tmp.in) expect_message( x <- .extract_tests_to_file(tmp.in, tmp.out, verbose=TRUE) , class = "testextra-message") expect_identical(x, character()) expect_false (file.exists(tmp.out)) } #' Extract tests from source #' #' Use this function to extract tests from package source files. #' In-source testing blocks are contained in blocks that are prevented #' from running when sourced by an `if(FALSE){...}` statement. #' It also contains a documentation tag to denote a testing block. #' #' The first line of the block should look similar to #' #' ``` #' if(FALSE){#@testing [optional information] #' ... #' } #' ``` #' @param pkg The root directory of the package. #' @param filter If specified, only tests from files matching #' this regular expression are extracted. #' @param verbose Print message? #' @param full.path Include full file paths in generated files. #' TRUE, indicates full path, #' FALSE, indicated only basename, and #' NA(default) implies path relative to `pkg`. #' @param force Force test extraction even if the generated test file #' is newer than the corresponding source file. #' @examples #' \dontrun{ #' # Extract all files #' extract_tests('.') #' #' # Extract only files that start with 'Class-' or 'class-' #' extract_tests('.', filter="^[Cc]lass-.*\\.[Rr]$") #' } extract_tests <- function( pkg = '.' #< package to extract tests for. , filter = NULL , verbose = getOption('verbose', FALSE) #< print messages , full.path = NA , force = FALSE #< Force extraction of tests. ){ #! Extract tests for testing directory. if (requireNamespace('devtools')){ pkg <- devtools::as.package(pkg) } else if (is.character(pkg) && file.exists(file.path(pkg, "DESCRIPTION"))) { # nocov start desc <- read.dcf(file.path(pkg, "DESCRIPTION")) desc <- structure(as.list(desc), names=tolower(colnames(desc))) desc$path <- normalizePath(pkg) pkg <- structure(desc, class = 'package') }# nocov end if (.Platform$OS.type == "windows") pkg$path <- normalizePath(pkg$path, '/') # nocov for(e in intersect(c('imports', 'suggests', 'depends', 'extends', 'collate'), names(pkg))) pkg[[e]] <- trimws(strsplit(pkg[[e]], "\\s*,\\s*")[[1]], 'both') if ( "testthat" %!in% pkg$suggests && "testthat" %!in% pkg$imports && "testthat" %!in% pkg$depends && "testthat" %!in% pkg$extends ) pkg_warning("testthat not found in suggests." %<<% "`extract_tests` assumes a testthat infrastructure.") test.dir <- file.path(pkg$path, "tests", "testthat") if (!file.exists(test.dir)) { pkg_message("Creating directory `"%<<<% test.dir %<<<%"`") %if% (verbose) #nocov dir.create(test.dir, recursive=TRUE) } if (!file.exists(.f <- file.path(test.dir, "..", "testthat.R"))){ pkg_message("creating file `"%<<<%normalizePath(.f)%<<<%"`") %if% (verbose) #nocov cat( c( paste0("# This file was created by `testextra::extract_tests` on ", Sys.time(), ".") , "# Once present, this file will not be overwritten and changes will persist." , "# To recreate the default version of this file delete and rerun `extract_tests`." , 'library(testthat)' , sprintf('test_check("%s")', pkg$package) ) , file=.f, sep='\n') } files <- if(is.na(full.path)){ old <- setwd(dir=pkg$path) on.exit(setwd(old)) file.path("R", list.files( "R", pattern="\\.r$", ignore.case=TRUE, full.names=FALSE)) } else if (full.path) { list.files( file.path(pkg$path, "R"), pattern="\\.r$", ignore.case=TRUE, full.names=TRUE) } else { old <- setwd(dir=file.path(pkg$path, 'R')) on.exit(setwd(old)) list.files( ".", pattern="\\.r$", ignore.case=TRUE, full.names=FALSE) } if (!is.null(filter)) { assert_that(is.string(filter)) which.files <- grepl(filter, sub("\\.[rR]$", "", basename(files)), perl = TRUE) if (!any(which.files)) pkg_error("Filtered to no files to extract from.") files <- files[which.files] } structure( lapply( files, .extract_tests_to_file , test.dir=test.dir , verbose=verbose , full.path = isTRUE(full.path) , force = force ) , names = files) } if(FALSE){#@testing tmp.dir <- normalizePath(tempdir(), '/', TRUE) if (!dir.exists(tmp.dir)) dir.create(tmp.dir) if (dir.exists(. <- file.path(tmp.dir, "testExtractionTest"))) unlink(., recursive = TRUE, force = TRUE) package.skeleton("testExtractionTest", path=tmp.dir, force=TRUE , code_files = list.files(system.file("testExtractionTest", "R", package='testextra'), full=TRUE) ) pkg <- file.path(tmp.dir, "testExtractionTest", fsep='/') expect_warning( result <- extract_tests(pkg) , "testthat not found in suggests. `extract_tests` assumes a testthat infrastructure.") test.dir <- file.path(tmp.dir, 'testExtractionTest', 'tests', 'testthat', fsep='/') expected <- structure( list( structure(c( "setClass(\"Test-Class\", ...)" , "show,Test-Class-method" , "setGeneric(\"yolo\", ...)" ) , test.file = file.path(test.dir, 'test-Class.R', fsep='/') ) , structure("hello_world" , test.file = file.path(test.dir, 'test-function.R', fsep='/') ) ) , names = file.path('R', c('Class.R', 'function.R')) ) test.dir <- normalizePath(file.path(pkg, "tests", "testthat"), '/', FALSE) expect_identical(list.files(test.dir), c('test-Class.R', 'test-function.R')) file <- file.path(test.dir, 'test-Class.R') expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `Class.R`')" , "#line 4 \"R/Class.R\"" ) ) expect_equal( result, expected) expect_true(dir.exists(file.path(pkg, "tests", "testthat"))) expect_true(file.exists(file.path(pkg, "tests", "testthat", "test-Class.R"))) expect_true(file.exists(file.path(pkg, "tests", "testthat", "test-function.R"))) description <- as.data.frame(read.dcf(file.path(pkg, 'DESCRIPTION'))) description$Suggests <- collapse(c('testthat', 'testextra'), ", ") write.dcf(description, file=file.path(pkg, 'DESCRIPTION')) unlink(sapply(expected, attr, 'test.file')) expect_silent(result <- extract_tests(pkg, full.path = TRUE)) expected <- structure( expected , names = file.path(pkg, 'R', c('Class.R', 'function.R'), fsep ="/")) expect_identical(result, expected) file <- file.path(test.dir, 'test-Class.R') from <- normalizePath(file.path(pkg, "R", "Class.R"), '/', FALSE) expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `" %<<<% from %<<<% "`')" , "#line 4 \"" %<<<% from %<<<%"\"" ) ) unlink(sapply(expected, attr, 'test.file')) expect_silent(result <- extract_tests(pkg, full.path = FALSE)) expected <- structure( expected , names = c('Class.R', 'function.R') ) expect_identical(result, expected) file <- file.path(test.dir, 'test-Class.R') from <- normalizePath(file.path(pkg, "R", "Class.R"), '/', FALSE) expect_identical( readLines(file)[c(1:5)] , c( "#! This file was automatically produced by the testextra package." , "#! Changes will be overwritten." , "" , "context('tests extracted from file `" %<<<% basename(from) %<<<% "`')" , "#line 4 \"" %<<<% basename(from) %<<<%"\"" ) ) unlink(pkg, recursive=TRUE, force = TRUE) } if(FALSE){#@testing pkg <- file.path(tempdir(), "testExtractionTest") if (dir.exists(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) package.skeleton("testExtractionTest", path=tempdir() , code_files = list.files(system.file("testExtractionTest", "R", package='testextra'), full=TRUE) ) test.dir <- normalizePath(file.path(pkg, "tests", "testthat"), '/', mustWork = FALSE) description <- as.data.frame(read.dcf(file.path(pkg, 'DESCRIPTION'))) description$Suggests <- collapse(c('testthat', 'testextra'), ", ") write.dcf(description, file=file.path(pkg, 'DESCRIPTION')) expect_identical(list.files(test.dir, full.names = TRUE),character()) result <- extract_tests(pkg, filter='Class', full.path = FALSE) expect_length(result, 1) expect_length(result[[1]], 3) expect_equal( structure(result[[1]], test.file=NULL) , c( 'setClass("Test-Class", ...)' , 'show,Test-Class-method' , 'setGeneric("yolo", ...)' ) ) expect_equal( normalizePath(attr(result[[1]], "test.file")) , normalizePath(file.path(test.dir, 'test-Class.R', fsep='/')) ) expect_true(dir.exists(test.dir)) expect_identical( list.files(test.dir, full.names = FALSE) , 'test-Class.R' ) expect_error(extract_tests(pkg, filter='bad filter', full.path = FALSE) , "Filtered to no files to extract from\\.") unlink(pkg, recursive = TRUE, force=TRUE) } #' Extract and run package tests #' #' This function corresponds to an intentionally masks [devtools::test()] #' from the [\code{devtools}](https://devtools.r-lib.org/) package. #' This version is polymorphic depending on the number of arguments given. #' #' When no arguments are provided all tests are extracted and run from #' the package corresponding to the active working directory. #' In other words `test()` is equivalent to `test(pkg='.', filter=NULL)` #' #' If arguments are provided they may be named. #' If any argument is named all must be named, if not found #' the two key parameters will be taken to be #' #' @param ... polymorphic arguments #' @param pkg The package to test. #' @param filter An optional filter to restrict the files to extract from and run tests for. #' @param file for `test_file` the exact file to extract and test from. #' #' @examples #' \dontrun{ #' # Extract and run all tests for the package in the #' # current working directory. #' test() #' #' # One argument form #' # extract and test class files for the #' # package in the current working directory. #' test("^Class-") #' #' # Two argument form #' # Extract files matching "Class" in the filename #' # for the package located at "inst/textExtractionTest" #' test("inst/testExtractionTest", "Class") #' #' } # nocov start test <- function( ... , pkg = switch( nargs(), '.', ..1) , filter = switch( ...length(), ..1, ..2) ){ if (nargs() > 2) pkg_error("too many arguments") if (is.null(pkg)) pkg <- '.' tests <- extract_tests(pkg, filter=filter) pkg_message(length(unlist(tests)) %<<<% ' test blocks extracted.\n') if (requireNamespace('devtools')) devtools::test(pkg=pkg, filter=filter, perl=TRUE) else stop('devtools is required to run the tests.') } #' RStudio add-ins addin_test <- function(){ stopifnot(requireNamespace("rstudioapi")) project <- rstudioapi::getActiveProject() if (is.null(project)) project <- getwd() try(test(pkg=project, filter=NULL)) } #' @rdname test extract_and_test_file <- function( file = rstudioapi::getSourceEditorContext()$path , pkg = rstudioapi::getActiveProject() ){ tests <- .extract_tests_to_file(file, verbose=TRUE) testthat::test_file( attr(tests, 'test.file') , env = asNamespace(basename(pkg))) } #' @rdname addin_test addin_test_file <- function(){ stopifnot(requireNamespace("rstudioapi")) pkg <- rstudioapi::getActiveProject() doc <- rstudioapi::getSourceEditorContext() rstudioapi::documentSave(doc$id) try(extract_and_test_file(doc$path, basename(pkg))) } # nocov end testextra/R/catch_condition.R0000644000175100001440000000470213402261031015762 0ustar hornikusers #' Catch a condition for testing. #' #' This function captures a condition object such as a warning or #' error, to allow for testing components and classes. #' #' @param code code to run that should assert a condition. #' @examples #' (cond <- catch_condition(stop("catch me."))) #' class(cond) #' #' my_fun <- function(){ #' message("a message") #' warning("a warning") #' pkg_message("a package message", scope="test") #' pkg_warning("a package warning", scope="test") #' pkg_error("a package error", scope='test') #' } #' conditions <- catch_all_conditions(my_fun()) #' conditions$messages #' conditions$warnings #' conditions$error # only one error can be caught at a time. #' catch_condition <- function(code){ val <- tryCatch(force(code), condition = function(cond)cond) if (is(val, 'condition')) return(val) } if(FALSE){#@testing val <- catch_condition(pkg_message("testing")) expect_is(val, 'condition') expect_is(val, 'message') } #' @rdname catch_condition catch_all_conditions <- function(code){ conditions <- list() tryCatch( withCallingHandlers( code , warning = function(cond){ conditions$warnings <<- c(conditions$warnings, list(cond)) invokeRestart("muffleWarning") } , message = function(cond){ conditions$messages <<- c(conditions$messages, list(cond)) invokeRestart("muffleMessage") }) , error = function(cond) conditions$error <<- cond , condition = function(cond) conditions$other <<- cond ) return(conditions) } if(FALSE){#@testing my_fun <- function(){ message("a message") warning("a warning") pkg_message("a package message", scope="test") pkg_warning("a package warning", scope="test") pkg_error("a package error", scope='test') } conditions <- catch_all_conditions(my_fun()) expect_length(conditions, 3) expect_is(conditions$error, 'test-error') expect_length(conditions$warnings, 2) expect_is(conditions$warnings[[1]], 'simpleWarning') expect_is(conditions$warnings[[2]], 'test-warning') expect_length(conditions$messages, 2) expect_is(conditions$messages[[1]], 'simpleMessage') expect_is(conditions$messages[[2]], 'test-message') } testextra/R/coverage.R0000644000175100001440000003214613411530006014431 0ustar hornikusers # nocov start # Single File Coverage ----- # Rendering ===== #' @name covr-rendering-single #' @title Rendering for single file report #' @description #' These functions facilitate the creation of reports for coverage of a #' single file. #' #' @param line,lines Line(s) number #' @param source source file #' @param coverage The number of times covered #' @param file the file in question #' @param report.file Where to output the HTML report. #' @param highlight Highlight the row. #' @param file_stats The coverage object for the file. #' @param dir the base directory for the HTML output #' @param libdir Where to put html dependencies? #' #' @family coverage NULL #' @rdname covr-rendering-single .renderSourceRow <- function(line, source, coverage) { requireNamespace('htmltools') cov_type <- NULL if (coverage == 0) { cov_value <- shiny::tags$td("!") cov_type <- "missed" } else if (coverage > 0) { cov_value <- with(shiny::tags, td( span(coverage, class="coverage-count") , em("x") , class='coverage' )) cov_type <- "covered" } else { cov_type <- "never" cov_value <-shiny::tags$td("") } line <- shiny::tags$td( class = "num" , line) src <- shiny::tags$td( class = "col-sm-12", shiny::tags$pre(class = "language-r", source)) htmltools::renderTags(htmltools::tags$tr( class = cov_type, line, src, cov_value)) } #' @rdname covr-rendering-single .renderSourceFile <- function(lines, file="source", highlight=TRUE) { assert_that( requireNamespace('htmltools') , requireNamespace('shiny') ) rows <- Map(.renderSourceRow, lines$line, lines$source, lines$coverage) html <- shiny::tags$div( id = file , class = "source-listing" , shiny::tags$table( class = "table-condensed" , shiny::tag('tbody', rows ) ) ) if (highlight) { highlight.deps <- htmltools::htmlDependency("highlight.js", "6.2", system.file(package = "shiny", "www/shared/highlight"), script = "highlight.pack.js", stylesheet = "rstudio.css") html <- htmltools::attachDependencies( html , c( htmltools::htmlDependencies(html) , list(highlight.deps) )) } return(htmltools::renderTags(html)) } #' @rdname covr-rendering-single .single_file_summary <- function(file_stats){ assert_that(requireNamespace('htmltools')) htmltools::renderTags( with(htmltools::tags, table(tbody( tr(th("Coverage:" ), td(shiny::HTML(file_stats$Coverage))) , tr(th("Total Lines:"), td(shiny::HTML(file_stats$Lines))) , tr(th("Relevant:" ), td(shiny::HTML(file_stats$Relevant))) , tr(th("Covered:" ), td(shiny::HTML(file_stats$Covered))) , tr(th("Missed:" ), td(shiny::HTML(file_stats$Missed))) , tr(th("Hits / Line:"), td(shiny::HTML(file_stats$`Hits / Line`))) )) ) ) } #' @rdname covr-rendering-single .renderReport <- function( coverage , report.file , dir = dirname(report.file) , libdir = file.path(dir, "lib") ) { assert_that( requireNamespace("shiny") , requireNamespace('covr') , requireNamespace('DT') , isNamespace(covr <- asNamespace('covr')) ) shiny.data <- covr$to_report_data(coverage) file <- attr(coverage, 'file') pkg <- attr(coverage, 'package') fname <- gsub(normalizePath(pkg$path, '/'), '', file, fixed = TRUE) shiny.summary <- DT::datatable( shiny.data$file_stats , escape = FALSE , options = list(searching = FALSE, dom = "t", paging = FALSE) , rownames = FALSE ) shiny.source <- .renderSourceFile(shiny.data$full[[1]]) ui <- shiny::fluidPage( shiny::includeCSS(system.file("www/report.css",package = "covr")) , title = paste0("{", pkg$package, "}", fname , " Coverage") , shiny::column( 8, offset=2 , htmltools::tags$h1( "Coverage for file" , htmltools::tags$pre(fname)) , shiny::tabsetPanel( shiny::tabPanel( htmltools::tags$h2("Summary") , .single_file_summary(shiny.data$file_stats) )) , shiny::tabsetPanel( shiny::tabPanel( htmltools::tags$h2("Source") , shiny.source )) ) ) ui <- htmltools::tags$body(ui, style = "background-color:white") ui <- htmltools::renderTags(ui) if (!dir.exists(libdir)) dir.create(libdir, recursive = TRUE) ui$dependencies <- lapply(ui$dependencies, function(dep) { dep <- htmltools::copyDependencyToDir(dep, libdir, FALSE) dep <- htmltools::makeDependencyRelative(dep, dir, FALSE) dep }) html <- c( "" , "" , "" , "" , htmltools::renderDependencies(ui$dependencies) , ui$head , "" , ui$html , "") writeLines(html, report.file, useBytes = TRUE) } # Computing ===== #' @name covr-single #' @title Single File Coverage #' @description #' These functions extract tests, run tests and create a report of the coverage for #' a single file. #' #' @param file The file to extract test from and compute coverage. #' @param pkg The package `file` is associated with. #' @inheritDotParams covr::file_coverage #' @param coverage Coverage returned from `file_coverage()`. #' @param report.file Where to save the HTML report. #' @param show.report if the HTML report should be displayed. NULL #' @describeIn covr-single Extract tests and compute the coverage for the given file. file_coverage <- function( file = rstudioapi::getSourceEditorContext()$path , pkg = '.' , ... ){ assert_that( requireNamespace('covr', quietly = TRUE) , requireNamespace('devtools', quietly = TRUE) , isNamespace(covr <- asNamespace('covr')) ) rstudioapi::documentSave() %if% missing(file) pkg <- devtools::as.package(pkg) if (!isNamespaceLoaded(pkg$package)) devtools::load_all(pkg$path) env <- asNamespace(pkg$package) covr$trace_environment(env) on.exit({ covr$reset_traces() covr$clear_counters() }) tests <- .extract_tests_to_file( file, verbose=TRUE) testthat::test_file(attr(tests, 'test.file'), env=env) coverage <- structure(as.list(covr$.counters), class = "coverage") coverage <- covr$exclude(coverage, ..., path=pkg$path) pat <- paste0("^", gsub("\\.", "\\\\.", basename(file)), ":[0-9:]+$") coverage <- structure( coverage[grepl(pat, names(coverage))] , class = 'coverage' , package=pkg , relative=TRUE , file=file ) } #' @describeIn covr-single Create a report for a single covr_file <- function( coverage = file_coverage() , report.file = NULL , show.report=interactive() ){ force(coverage) assert_that( requireNamespace("shiny") , requireNamespace('covr') , requireNamespace('DT') , isNamespace(covr <- asNamespace('covr')) ) if (is.null(report.file)) report.file <- file.path(tempdir(), paste0("coverage-report-", basename(attr(coverage, 'file')), ".html")) report.file <- normalizePath(report.file, '/', FALSE) .renderReport(coverage, report.file) if (show.report) rstudioapi::viewer(report.file) # nocov invisible(report.file) } if(FALSE){# Interactive testing, do not extract. #single file extract and coverage tmp.dir <- normalizePath(tempdir(), '/') pkg <- file.path(tmp.dir, "testExtractionTest") if (dir.exists(pkg)) unlink(pkg, recursive = TRUE, force = TRUE) package.skeleton("testExtractionTest" , path=tmp.dir, force=TRUE , code_files = list.files(system.file("testExtractionTest", "R", package='testextra'), full=TRUE) ) dir.create(file.path(pkg, 'tests', 'testthat'), recursive = TRUE) file <- file.path(pkg, 'R', 'function.R') expect_true(file.exists(file)) coverage <- file_coverage(file, pkg) expect_is(coverage, 'coverage') expect_length(names(coverage), 1L) expect_true(file.exists(file.path(pkg, 'tests', 'testthat', 'test-function.R'))) report.file <- file.path(pkg, 'covr', 'covr-function.html') expect_null(.renderReport(coverage, report.file)) expect_true(file.exists(report.file)) output <- covr_file(coverage, report.file, FALSE) expect_identical(output, report.file) output.lines <- readLines(output) output.lines <- gsub( "data-tabsetid=\"\\d+\"" , "data-tabsetid=\"1234\"" , output.lines) output.lines <- gsub( "\"(#?)tab-\\d+-1\"" , "\"\\1tab-1234-1\"" , output.lines) expected.lines <- readLines(system.file("testExtractionTest", "covr-expected", "covr-function.html", package='testextra')) expected.lines <- gsub( "data-tabsetid=\"\\d+\"" , "data-tabsetid=\"1234\"" , expected.lines) expected.lines <- gsub( "\"(#?)tab-\\d+-1\"" , "\"\\1tab-1234-1\"" , expected.lines) expect_identical(output.lines, expected.lines) } ### Coverage for File Groups ##### #' Compute coverage for a group of files. #' #' @param filter A regular expression filter to apply to the files from `pkg`. #' @param pkg The package to compute coverage for. #' @param report If a report should be constructed and shown. covr_files <- function( filter , pkg = '.' , report = TRUE ){ pkg <- devtools::as.package(pkg) assert_that( requireNamespace("shiny") , requireNamespace('covr') , isNamespace(covr <- asNamespace('covr')) , isNamespace(testthat <- asNamespace('testthat')) ) rstudioapi::documentSaveAll() devtools::load_all(pkg) tests <- extract_tests(pkg, filter=filter, verbose=TRUE) pkg_message(length(unlist(tests)) %<<% 'test blocks extracted' %<<% "from" %<<% length(Filter(length, tests)) %<<<% '/' %<<<% length(tests) %<<% 'files.\n' ) if (requireNamespace('devtools')) { devtools::test(pkg=pkg, filter=filter, perl=TRUE) } src.files <- names(tests) test.files <- as.character(purrr::compact(purrr::map(tests, attr, 'test.file'))) env <- asNamespace(pkg$package) covr$trace_environment(env) on.exit({ covr$reset_traces() covr$clear_counters() }) testthat$test_files(test.files) coverage <- structure(as.list(covr$.counters), class = "coverage") coverage <- covr$exclude(coverage, path=pkg$path) pat <- paste0("^(", collapse(gsub("([.])", "\\\\\\1", basename(src.files)), '|'), "):[0-9:]+$") coverage <- structure( coverage[grepl(pat, names(coverage))] , class = 'coverage' , package=pkg , relative=TRUE , file=file ) if (report) covr::report(coverage, browse = TRUE) invisible(coverage) } # nocov end # RStudio Addins ---------------------------------------------------------- # nocov start #' Add-in for `covr_file` #' #' This allows for [covr_file] to be run from a menu in RStudio. addin_covr_file <- function(){ stopifnot(requireNamespace("rstudioapi")) pkg <- rstudioapi::getActiveProject() doc <- rstudioapi::getSourceEditorContext() rstudioapi::documentSave(doc$id) try(covr_file( file_coverage(doc$path, pkg = pkg) , show.report = TRUE )) } #' Add-in for Extract & Coverage #' #' addin_extract_covr <- function(){ stopifnot(requireNamespace("rstudioapi")) project <- rstudioapi::getActiveProject() if (is.null(project)) project <- getwd() try({ extract_tests(project) covr::report(covr::package_coverage(project)) }) } # nocov end testextra/NEWS.md0000644000175100001440000000013613413727035013416 0ustar hornikusers# testextra 0.1 * Added a `NEWS.md` file to track changes to the package. * Initial Release. testextra/MD50000644000175100001440000000511613576367061012644 0ustar hornikusersc5842e143930555d5bf61d8a5c9756ba *DESCRIPTION 42f339482cd9867c025c13382d820a11 *NAMESPACE 62146256f318bf4d9f0a6c4e1afe3e93 *NEWS.md 1fb27662d38b56b02001a9388728a882 *R/catch_condition.R 70a162973887c648893e11508aac1a62 *R/coverage.R 7452f39c9939e73ec221de9023f64bd7 *R/extract_tests.R 5391a3c5a88307f46f22f1e52a308b94 *R/inheritance.R 3062d5ba7f698bafeb550ebfaebb3b59 *R/new_namespace.R e89d7220652c4d829446259c4f8465ed *R/strings.R 5f4e30d3a5a248b40e4c5bce1b9fd7ad *R/util-testing.R a854c5708b3524b86db0fbb3f8e28ac1 *R/validity.R 5e534725328dfec151b73943a3508cea *README.md 1deaaa20f483fc0f6cf4912584f41102 *inst/WORDLIST 9afa6da0b7b4017518f05c14d1024b1c *inst/examples/example-class-expectations.R 68f5632547e60331c9ef31b8698a4d19 *inst/examples/example-class-tests.R a426edc09ddc72c5f5dabc81b30bfe65 *inst/examples/example-namespace.R 6a15203b230057b64f64b83e581bde50 *inst/rstudio/addins.dcf 2f45c16fffa748e329bacf9565380f08 *inst/testExtractionTest/R/Class.R f562dc68e7fdf0009331c6c58252d5e6 *inst/testExtractionTest/R/function.R 2ff1c89e205b0bfdce40790de32a641d *inst/testExtractionTest/covr-expected/covr-function.html 86decd04c961f70c09ecb05782552e5a *man/addin_covr_file.Rd d59528a39c0e1c56569298266ae805a1 *man/addin_extract_covr.Rd cb2bf7f65737d7b2ca96fb109eeffe8b *man/addin_test.Rd cc18df9350feb8a62cfc0c0583101387 *man/catch_condition.Rd 9705d81cddeddb7fa8d8607569405c72 *man/class-expectations.Rd 1688abc5757820a7b7061aed90d5f724 *man/class-tests.Rd 25e2e6d19cfb172e8116c20920b7bc60 *man/class0.Rd 393ae3589cae901a3a198f0bc898b915 *man/covr-rendering-single.Rd 61f4914fa062e867094fb44ca46ada8f *man/covr-single.Rd 85b709f69cb6a3def99a3f878bfa37aa *man/covr_files.Rd 789f23f4b2462bb10ed2b49efd8f6fd3 *man/expect_valid.Rd 9ae77c79c5f3c82f14704a5c762d41bb *man/extract_tests.Rd 9789414b122f0236cc35e6ca31e81fa3 *man/figures/logo.png b4f406bc461b566d1dd89897d3d43a6b *man/is_valid_regex.Rd 35ea0c8a0761405585a3edf12c3f5159 *man/namespaces.Rd 54e57d5cce9d466b40ac895632919991 *man/string-tests.Rd 8cfc8d781f2806577060d4e749f84f8e *man/test.Rd ad1c88469e20abbb5301e26f813e445d *man/validity-tests.Rd 42b96257e36939414deb5066cdd6e2e4 *tests/testthat.R 8e87f7cade5a59f2594d872f35a76188 *tests/testthat/test-catch_condition.R c4c4d9326513c5475ff11daadf3f4287 *tests/testthat/test-extract_tests.R c333afccead0aea43b553bb4fc8d2b6f *tests/testthat/test-inheritance.R d1f1fef9e94bc5495e809f499de19217 *tests/testthat/test-new_namespace.R a997ab01ceef648b0fd8e79965146e71 *tests/testthat/test-strings.R 8250b95b805d342b3e8d46fc2619ca73 *tests/testthat/test-util-testing.R 3d648499a39f5c6fdb30daddc69e860d *tests/testthat/test-validity.R testextra/inst/0000755000175100001440000000000013411531473013272 5ustar hornikuserstestextra/inst/examples/0000755000175100001440000000000013402562422015106 5ustar hornikuserstestextra/inst/examples/example-namespace.R0000644000175100001440000000112613402257060020615 0ustar hornikusersns <- new_namespace_env('my namespace') isNamespace(ns) environmentName(ns) packageName(ns) # not a package pkg <- new_pkg_environment("myPackage") isNamespace(pkg) environmentName(pkg) packageName(pkg) # now a package is_namespace_registered(pkg) # but not registered \dontrun{ asNamespace("myPackage") # so this WILL NOT work. } register_namespace(pkg) is_namespace_registered(pkg) # now registered asNamespace("myPackage") # so this WILL work. unregister_namespace(pkg) is_namespace_registered(pkg) # now unregistered isNamespace(pkg) # but still a namespace testextra/inst/examples/example-class-expectations.R0000644000175100001440000000031313402262721022467 0ustar hornikusers # Test to make sure an object is not of a class. \dontrun{ # will return an error. expect_is_not(1L, "numeric") } # but this is fine. expect_is_not('a', "numeric") expect_is_exactly('a', "character") testextra/inst/examples/example-class-tests.R0000644000175100001440000000054413402261755021137 0ustar hornikuserslst <- list(1L, 2, TRUE) # all_inherit uses `inherits` all_inherit(lst, 'numeric') all_inherit(lst, 'integer') all_inherit(lst, 'ANY') # are uses `is` so gets different results. are(lst, "numeric") are(lst, "integer") are(lst, "ANY") # is_exactly the class must match exactly is_exactly(1L, "integer") # no inheritance allowed is_exactly(1L, "numeric") testextra/inst/rstudio/0000755000175100001440000000000013402562417014765 5ustar hornikuserstestextra/inst/rstudio/addins.dcf0000644000175100001440000000113213402251147016675 0ustar hornikusersName: Extract & covr package Description: Run `extract_tests()` `devtools::test()` for the curent project. Binding: addin_extract_covr Interactive: false Name: Extract & run tests Description: Run `extract_tests()` and `test()` for the curent project. Binding: addin_test Interactive: false Name: Extract & test active file Description: Extract and run tests from active file in Rstudio. Binding: addin_test_file Interactive: false Name: Extract & covr active file Description: Extract tests, Run tests, report coverage results for active file in Rstudio. Binding: addin_covr_file Interactive: falsetestextra/inst/testExtractionTest/0000755000175100001440000000000013372721660017157 5ustar hornikuserstestextra/inst/testExtractionTest/R/0000755000175100001440000000000013372453400017352 5ustar hornikuserstestextra/inst/testExtractionTest/R/function.R0000644000175100001440000000027513137666665021350 0ustar hornikusers# A test cases for extracting tests from a package structure. hello_world <- function(){ print("hello world") } if(FALSE){#!@testthat expect_output(hello_world(), "hello world") } testextra/inst/testExtractionTest/R/Class.R0000644000175100001440000000062613137666665020570 0ustar hornikusers# A test cases for extracting tests from a package structure. setClass("Test-Class") if(FALSE){#!@test expect_true(TRUE) expect_is(getClass("Test-Class"), "classRepresentation") } setMethod("show", "Test-Class", function(object){cat("hi")}) if(FALSE){#!@test expect_true(TRUE) } setGeneric("yolo", function(object, ...){cat("you only live once!")}) if(FALSE){#!@test expect_true(TRUE) } testextra/inst/testExtractionTest/covr-expected/0000755000175100001440000000000013372721662021731 5ustar hornikuserstestextra/inst/testExtractionTest/covr-expected/covr-function.html0000644000175100001440000001233313372721572025415 0ustar hornikusers {testExtractionTest}/R/function.R Coverage

Coverage for file
/R/function.R

Coverage: 100.00%
Total Lines: 8
Relevant: 1
Covered: 1
Missed: 0
Hits / Line: 1
1
# A test cases for extracting tests from a package structure.
2

  
3
hello_world <- function(){
4
    print("hello world")
1 x
5
}
6
if(FALSE){#!@testthat
7
    expect_output(hello_world(), "hello world")
8
}
testextra/inst/WORDLIST0000644000175100001440000000001113411531473014454 0ustar hornikusersRStudio