Nothing
{#######################################################################
# testing_blocks.R
# This file is part of the R package `parsetools`.
#
# Author: Andrew Redd
# Copyright: 2017 The R Consortium
#
# LICENSE
# ========
# The R package `parsetools` 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 2 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/.
#
}#######################################################################
.testing.tags <- c("test", "tests", "testing", "testthat")
#' @export
extract_test_block <-
function( id = all_tagged_iff_block_ids(pd, .testing.tags)
, pd = get('pd', parent.frame())
){
#' @title Extract testing blocks from the parse-data.
#' @param pd a \link{parse-data} object.
pd <- ._check_parse_data(pd)
#' @param id iff block id, not the content
id <- ._check_id(id)
if (length(id) > 1){
.l <- lapply(id, extract_test_block, pd=pd)
return(structure( c(.l, recursive=TRUE)
, test.names = sapply(.l, attr, 'name')
, start.locations = utils::head(cumsum(c(1, sapply(.l, length))),-1)
))
}
#' @description
#' Extract the content of a testing block as a character vector of lines.
#' The name, which is attached as an attribute is taken from the info
#' string or inferred by location, see Details.
#'
stopifnot(pd_is_iff_block(id,pd))
content.id <- if_branch(id, pd)
tag.comment <- children(content.id, pd)[[2]]
info.string <- trimws(strip_doc_comment_leads(strip_tag(text(tag.comment), .testing.tags)))
content <- lines(content.id, pd)
name <- if (!is.null(info.string) && info.string!='') {
info.string
} else {
#! @details
#! After the `@` tag you may provide an information
#! string. At the moment the information string is
#! only used for two things. First to infer the `desc`
#! argument of the generated `<test_that>` call.
#! Second, the information string will be used in the
#! absence of a provided `file.out` to name the output file,
#! which will be prefixed by "test-" and placed in the `dir`
#! directory.
#!
name <- iff_associated_name(id, pd)
if(is.null(name))
stop( "illformed block at "
, paste( filename(pd), start_line(id), start_col(id), sep=':')
)
if (attr(name, 'type') == 'setGeneric')
paste0("setGeneric(\"", name, "\", ...)")
else if(attr(name, 'type') == 'setClass')
paste0("setClass(\"", name, "\", ...)")
else if(attr(name, 'type') == 'setAs')
deparse(call("as", as.name(attr(name, 'from')), attr(name,"to")))
else
name
}
line.directive <- paste("#line", start_line(content.id), paste0('"', filename(pd), '"'))
out.text <- if (length(content)<2)
sprintf("test_that('%s', %s)", name, content)
else
out.text <- c( sprintf("test_that('%s', %s", name, content[[1]])
, content[-c(1, length(content))]
, paste0(content[length(content)], ")"))
out.text <- c( line.directive, out.text)
structure(out.text, name = name)
#' @return a character vector with the lines for the specific test(s)
#' with the name of the test included as an attribute.
}
if(FALSE){#!@testing
pd <- get_parse_data(parse(text={'
if(F){#!@testing
# a malplaced testing block
FALSE
}
hello_world <- function(){
print("hello world")
}
if(FALSE){#!@testthat
expect_output(hello_world(), "hello world")
}
ldf <- data.frame(id = 1:26, letters)
if(FALSE){#!@testing
# not a function assignment
}
f2 <- function(){stop("this does nothing")}
if(F){#! @example
hw()
}
if(F){#! @test
expect_error(f2())
}
setClass("A")
if(F){#!@testing
#testing a setClass
}
setMethod("print", "A")
if(F){#!@testing
#testing a setMethod
}
setGeneric("my_generic", function(x){x})
if(F){#!@testing
#testing a setClass
}
rnorm(10)
if(F){#!@testing
# no previous name
}
setAs("class1", "class2", function(from){new(from[[1]], "class2")})
if(F){#!@testing
#testing setAs
}
'}, keep.source=TRUE))
iff.ids <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test'))
expect_error( extract_test_block(iff.ids[[1L]], pd)
, "illformed block at <text>:2:5"
, info = "cannot find name for block"
)
expect_equal( extract_test_block(iff.ids[[2L]], pd)
, structure(c( '#line 9 "<text>"'
, 'test_that(\'hello_world\', {#!@testthat'
, ' expect_output(hello_world(), "hello world")'
, ' })'
), name=structure("hello_world", type = "function_assignment"))
, info="testing after function assignment")
expect_equal( extract_test_block(iff.ids[[3L]], pd)
, structure(c( '#line 14 "<text>"'
, 'test_that(\'ldf\', {#!@testing'
, ' # not a function assignment'
, ' })'
), name = structure("ldf", type = "assignment"))
, info="testing after other assignment")
expect_equal( extract_test_block(iff.ids[[4L]], pd)
, structure(c( '#line 22 "<text>"'
, 'test_that(\'f2\', {#! @test'
, ' expect_error(f2())'
, ' })'
), name=structure("f2", type = "function_assignment"))
, info="testing after other iff")
expect_equal( extract_test_block(iff.ids[[5L]], pd)
, structure(c( '#line 27 "<text>"'
, 'test_that(\'setClass("A", ...)\', {#!@testing'
, ' #testing a setClass'
, ' })'
), name="setClass(\"A\", ...)")
, info="testing after setClass")
expect_equal( extract_test_block(iff.ids[[6L]], pd)
, structure(c( '#line 32 "<text>"'
, 'test_that(\'print,A-method\', {#!@testing'
, ' #testing a setMethod'
, ' })'
), name=structure("print,A-method", type = "setMethod"))
, info="testing after setMethod")
expect_equal( extract_test_block(iff.ids[[7L]], pd)
, structure(c( '#line 37 "<text>"'
, 'test_that(\'setGeneric("my_generic", ...)\', {#!@testing'
, ' #testing a setClass'
, ' })'
), name="setGeneric(\"my_generic\", ...)")
, info="testing after setGeneric")
expect_error( extract_test_block(iff.ids[[8L]], pd)
, info="following call")
expect_equal( extract_test_block(iff.ids[2:3], pd)
, structure(c( '#line 9 "<text>"'
, 'test_that(\'hello_world\', {#!@testthat'
, ' expect_output(hello_world(), "hello world")'
, ' })'
, '#line 14 "<text>"'
, 'test_that(\'ldf\', {#!@testing'
, ' # not a function assignment'
, ' })'
)
, test.names = c("hello_world", "ldf")
, start.locations = c(1, 5)
)
, info = "multiple ids")
expect_equal( extract_test_block(iff.ids[9], pd)
, structure(c( '#line 47 "<text>"'
, 'test_that(\'as(class1, "class2")\', {#!@testing'
, ' #testing setAs'
, ' })'
)
, name = c("as(class1, \"class2\")")
)
, info = "setAs")
}
if(FALSE){#@testing Extraction with block tag.
pd <- get_parse_data(parse(text={"
if(FALSE){#@testing An info string
expect_true(T)
}
"}, keep.source = TRUE))
expect_equal( extract_test_block(roots(pd), pd)
, structure(c( "#line 2 \"<text>\""
, "test_that('An info string', {#@testing An info string"
, " expect_true(T)"
, " })"
)
, name = "An info string")
, info = "using text string")
}
#@internal
extract_test_blocks_parse_data <-
function( pd ){
pd <- ._check_parse_data(pd)
iff.ids <- all_tagged_iff_block_ids(pd, .testing.tags)
.l <- lapply(iff.ids, extract_test_block, pd=pd)
if (length(.l)==0) return(NULL)
return(structure( c(.l, recursive=TRUE)
, test.names = sapply(.l, attr, 'name')
, start.locations = utils::head(cumsum(c(1, sapply(.l, length))),-1)
))
}
if(FALSE){#@testing
ex.file <- system.file("examples", "example.R", package="parsetools")
exprs <- parse(ex.file, keep.source = TRUE)
pd <- get_parse_data(exprs)
expect_null(extract_test_blocks_parse_data(pd))
}
#' @export
extract_test_blocks <-
function( file ){
#' @title extract tests from a file.
#' @param file the file to retrieve tests from.
#' @description
#' Convenience function for extracting all tests from a file.
#' This parses the file and passes the work to
#' \code{\link{extract_test_block}}.
pd <- get_parse_data(parse(file=file, keep.source = TRUE))
extract_test_blocks_parse_data(pd)
}
if(FALSE){#! @testthat
text <- {'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()
}
'}
tmp <- tempfile(fileext = ".R")
writeLines(text, tmp)
test.blocks <- extract_test_blocks(tmp)
expect_equal( test.blocks
, structure(c( sprintf('#line 4 "%s"', tmp)
, 'test_that(\'hello_world\', {#!@testthat'
, ' expect_output(hello_world(), "hello world")'
, '})'
, sprintf('#line 9 "%s"', tmp)
, 'test_that(\'f2\', {#! @test'
, ' expect_error(f2())'
, '})'
)
, test.names = c("hello_world", "f2")
, start.locations = c(1, 5)
)
, info = "Write to file and read back.")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.