# get_parse_data.R #####################################################
# #
# This file is part of the R package `parsetools`. #
# #
# Author: Andrew Redd #
# Copyright: 2018 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/. #
#_____________________________________________________________________#
.pd.expected.names <-{c( 'line1', 'col1', 'line2', 'col2', 'id'
, 'parent', 'token', 'terminal', 'text'
)}
# Internal Helpers =====================================================
#@internal
get_srcfile <- function(x){
#! replicate of unexported function get_srcfile from utils.
result <- attr(x, "srcfile")
if (!is.null(result))
return(result)
srcref <- attr(x, "wholeSrcref")
if (is.null(srcref)) {
srcref <- utils::getSrcref(x)
if (is.list(srcref) && length(srcref))
srcref <- srcref[[length(srcref)]]
}
attr(srcref, "srcfile")
}
if(FALSE){#@testing
ex.file <- system.file("examples", "example.R", package="parsetools")
exprs <- parse(ex.file, keep.source = TRUE)
pd <- get_parse_data(exprs)
sf <- attr(exprs, 'srcfile')
expect_identical(get_srcfile(exprs), sf)
attr(exprs, 'srcfile') <- NULL
expect_identical(get_srcfile(exprs), sf)
attr(exprs, "wholeSrcref") <- NULL
expect_identical(get_srcfile(exprs), sf)
}
fix_eq_assign <-
function( pd #< The [parse-data] to fix
){
#! Fix the parents for expressions associated with EQ_ASSIGN tokens.
# if ( R.version$major > 3
# || ( R.version$major == 3
# && R.version$minor >= 6.0 ))
# return (pd)
ids <- pd[pd[['token']] == "EQ_ASSIGN", 'id']
for(id in rev(ids)) if (!identical(token(parent(id)), 'equal_assign'))
{
fam.pd <- get_children_pd(parent(id), pd, .check=FALSE)
fam.pd <- fam.pd[order(fam.pd$id), ]
fam.pd <- utils::head(fam.pd[fam.pd$id >= id, ], 3)
new.id <- max(pd$id)+1L
fam.pd$parent <- new.id
line1 = min(fam.pd$line1)
col1 = min(fam.pd[fam.pd$line1==line1, 'col1'])
line2 = max(fam.pd$line2)
col2 = max(fam.pd[fam.pd$line2==line2, 'col2'])
pd <-
rbind( pd[!(pd$id %in% c(fam.pd$id)), ]
, data.frame( line1, col1
, line2, col2
, id = new.id
, parent = parent(id)
, token = 'equal_assign'
, terminal= FALSE
, text = ''
)
, fam.pd
)
}
pd[do.call(order, pd), ]
}
if(F){#! @testthat
pd <- utils::getParseData(parse(text="a=1", keep.source=TRUE))
fixed.pd <- fix_eq_assign(pd)
expect_true('equal_assign'%in% fixed.pd$token)
expect_true('EQ_ASSIGN'%in% fixed.pd$token)
expect_that(sum(fixed.pd$parent==0), equals(1))
expect_identical(fixed.pd, fix_eq_assign(fixed.pd))
pd <- utils::getParseData(parse(text="a=1\nb<-2\nc=3\nd<<-4", keep.source=TRUE))
fixed.pd <- fix_eq_assign(pd)
expect_true('equal_assign'%in% fixed.pd$token)
expect_true('EQ_ASSIGN'%in% fixed.pd$token)
expect_that(sum(fixed.pd$parent==0), equals(4))
expect_identical(fixed.pd, fix_eq_assign(fixed.pd))
pd <- utils::getParseData(parse(text="a=b=1", keep.source=TRUE))
fixed.pd <- fix_eq_assign(pd)
expect_true('equal_assign'%in% fixed.pd$token)
expect_true('EQ_ASSIGN'%in% fixed.pd$token)
expect_that(sum(fixed.pd$parent==0), equals(1))
expect_identical(fixed.pd, fix_eq_assign(fixed.pd))
}
# get_parse_data =======================================================
#' @aliases parse-data
#' @title Parse Data
#'
#' @param x an object to get parse-data from.
#' @param ... options for specific type of objects.
#'
#' @description
#' Parsing data is at the core of parse tools and thus at the core
#' of the documentation package. The \code{get_parse_data} function is
#' essentially a customized version of `<getParseData>` that will return
#' a cleaned up version of the parse data for a variety of objects.
#' This version also fails less often, even reparsing text when
#' needed.
#' @export
#' @example inst/examples/example-get_parse_data.R
get_parse_data <- function(x, ...)UseMethod("get_parse_data")
if(FALSE){#@example
text <- " my_function <- function(object #< An object to do something with
){
#' A title
#'
#' A Description
print(\"It Works!\")
#< A return value.
}"
source(textConnection(text), keep.source = TRUE)
# Get parse data from a function
(pd <- get_parse_data(my_function))
# which must have a srcref attribute.
# You can call the get_parse data directly on the srcref object.
src <- utils::getSrcref(my_function)
pd2 <- get_parse_data(src)
identical(pd, pd2)
# Objects must have a srcref.
utils::getSrcref(rnorm)
expect_error(get_parse_data(rnorm), "x does not have a valid srcref.")
}
#' @describeIn get_parse_data
#' @export
get_parse_data.srcfile <-
function( x
, ... #< discarded
){
#' @rdname get_parse_data
stopifnot(inherits(x, 'srcfile'))
df <- if (!is.null(x$parseData)) as.data.frame.parseData(x$parseData, x, ...)
else if (!is.null(x$lines ) && length(x$lines) ) utils::getParseData(parse(text=x$lines, keep.source=TRUE), ...)
else if (!is.null(x$filename ) && x$filename != "") utils::getParseData(parse(x$filename , keep.source=TRUE), ...)
else stop("could not retrieve parse-data for ", deparse(substitute(x)))
structure(as_parse_data(df), srcfile = x)
}
if(FALSE){#@testing
text <- " my_function <- function(object #< An object to do something with
){
#' A title
#'
#' A Description
print(\"It Works!\")
#< A return value.
}"
tmp <- tempfile()
writeLines(text, tmp)
readLines(tmp)
source(tmp, keep.source = TRUE)
srcref <- utils::getSrcref(my_function)
srcfile <- attr(srcref, 'srcfile')
expect_equal(srcfile$filename, tmp)
expect_is(srcfile$parseData, 'parseData')
pd <- get_parse_data.srcfile(srcfile)
expect_is(pd, 'parse-data', info = "srcfile with parseData")
expect_identical(attr(pd, 'srcfile'), srcfile, info='carried forward srcfile')
remove('parseData', envir = srcfile)
expect_null(srcfile$parseData)
expect_is(srcfile$lines, 'character')
pd <- get_parse_data.srcfile(srcfile)
expect_is(pd, 'parse-data', info = "srcfile from lines")
remove('lines', envir = srcfile)
expect_null(srcfile$parseData)
expect_null(srcfile$lines, 'character')
pd <- get_parse_data.srcfile(srcfile)
expect_is(pd, 'parse-data', info = "srcfile from file directly")
remove('filename', envir = srcfile)
expect_error(get_parse_data.srcfile(srcfile), "could not retrieve parse-data for srcfile")
unlink(tmp)
}
#' @export
get_parse_data.srcref <-
function( x
, ... #< passe to <getParseData>
, ignore.groups = TRUE
, include.doc.comments = TRUE
, include.regular.comments = FALSE
){
#' @rdname get_parse_data
#'
#' @inheritParams ascend_to_root
#' @inheritParams get_family_pd
stopifnot(inherits(x, 'srcref'))
pd <- get_parse_data.srcfile(attr(x, 'srcfile'), ...)
id <- pd_identify(pd, x)
root <- ascend_to_root(id, pd, ignore.groups=ignore.groups)
if (!length(root)) return(NULL) # nocov
structure(id = id, root=root,
get_family_pd( root, pd
, include.doc.comments = include.doc.comments
, include.regular.comments = include.regular.comments
))
}
if(FALSE){#@testing
text <-{"my_function <-
function( object #< An object to do something with
){
#' A title
#'
#' A Description
print('It Works!')
#< A return value.
}
another_f <- function(){}
if(F){}
"}
p <- parse(text=text, keep.source=TRUE)
e <- new.env()
eval(p, envir=e)
srcref <- utils::getSrcref(e$my_function)
srcfile <- get_srcfile(e$my_function)
expect_is(srcref, 'srcref')
pd <- get_parse_data.srcref(srcref)
expect_is(pd, 'parse-data')
expect_identical(attr(pd, 'srcfile'), srcfile)
}
#' @export
get_parse_data.function <-
function(x, ...){
#' @describeIn get_parse_data Get parse information from a function.
#' The function must have a [`srcref`][base::srcref].
stopifnot(is.function(x))
if (methods::isGeneric(fdef=x)) {
default <- attr(x, 'default')
if (is.null(default) || !is.function(default))
stop( deparse(substitute(x))
, " appears to be a generic, but could not find the"
, " default method, where parse data should be found.")
return(Recall(default, ...))
}
get_parse_data.default(x, ...)
}
if(FALSE){#@test get_parse_data.function basic
test.text <-
"#' Roxygen Line Before
hw <-
function(x){
#' line inside
cat(\"hello world\")
}
another_fun <- function(){TRUE}
"
eval(parse(text=test.text, keep.source=TRUE))
x <- fun <- hw
pd.regular <- get_parse_data(hw)
expect_that(pd.regular, is_a("data.frame"))
expect_that(pd.regular[1,"text"], equals("#' Roxygen Line Before"))
}
if(FALSE){#@test get_parse_data.function grouped
grouped.text <-
"{#' Roxygen Line Before
hw <-
function(x){
#' line inside
cat(\"hello world\")
}}"
parsed <- parse(text=grouped.text, keep.source=TRUE)
raw.pd <- get_parse_data(parsed)
eval(parsed)
fun <- hw
pd <- get_parse_data(hw)
expect_is(pd, "parse-data")
expect_that(pd[1,"text"], equals("#' Roxygen Line Before"))
}
if(FALSE){#@test get_parse_data.function nested
nested.text <-{
"{# Section Block
#' Roxygen Line Before
nested <-
function(x){
#' line inside
cat(\"hello world\")
}
}
"}
eval(parse(text=nested.text, keep.source=TRUE))
x <- fun <- nested
pd <- get_parse_data(nested)
expect_is(pd, "data.frame")
expect_is(pd, "parse-data")
# pd <- get_parse_data(function(){})
# expect_that(pd, is_a("data.frame"))
}
if(FALSE){#@test get_parse_data.function S4 Generic
# Note that testthat:::test_code will strip comments from code
# this requires a parse & eval statement.
p <- parse(text="setGeneric(\"my_generic\",
function(object #< An object to do something with
){
#' A title
#'
#' A Description
print(\"It Works!\")
#< A return value.
})", keep.source=TRUE)
eval(p)
expect_null(utils::getParseData(my_generic))
expect_true(isGeneric(fdef = my_generic))
pd <- get_parse_data(my_generic)
expect_is(pd, 'parse-data')
}
if(FALSE){#@test get_parse_data.function
p <- parse(text='setGeneric("test_generic",
function(object
){
value <- standardGeneric("test_generic")
})', keep.source=TRUE)
eval(p)
expect_true(isGeneric(fdef = test_generic))
expect_error( get_parse_data(test_generic)
, "could not find the default method")
}
#' @export
get_parse_data.default <-
function( x, ...){
#! the default get_parse_data method
#!
#! This extracts the [base::srcref()] and uses that to obtain the parse data.
#! Currently I have only found srcrefs as attributes of functions.
srcref <- utils::getSrcref(x)
if (!is.null(srcref) && inherits(srcref, 'srcref')) {
get_parse_data.srcref(srcref, ...)
} else {
srcfile <- get_srcfile(x)
if (!is.null(srcfile))
get_parse_data.srcfile(srcfile)
else
stop(deparse(substitute(x)), " does not have a valid srcref.")
}
}
if(FALSE){#@testing
x <-
exprs <- parse(text=c('x <- rnorm(10, mean=0, sd=1)'
,'y <- mean(x)'
), keep.source=TRUE)
pd <- get_parse_data(exprs, keep.source=TRUE)
expect_is(pd, 'parse-data', info = "get_parse_datwa.default with srcfile")
expect_error(get_parse_data.default(datasets::iris)
, "datasets::iris does not have a valid srcref\\.")
}
#' @export
`subset.parse-data` <- function(x, ...)structure(NextMethod(), class=c('parse-data', 'data.frame'))
if(FALSE){#@testing
pd <- get_parse_data(parse(text={
"{# Section Block
#' Roxygen Line Beore
nested <-
function(x){
#' line inside
cat(\"hello world\")
}
}
"
}, keep.source=TRUE))
expect_is(pd, 'parse-data')
pd2 <- pd[pd$line1 > 3, ]
expect_is(pd2, 'parse-data')
expect_equal(min(pd2$line1), 4)
}
# S3 Methods ===========================================================
#' @export
`[.parse-data` <- function(x, ...){
result <- NextMethod()
if (inherits(result, 'data.frame'))
structure(result, class=c('parse-data', 'data.frame'))
else
result
}
if(FALSE){#@testing
pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE))
expect_is(pd, 'parse-data')
expect_is(pd[pd$parent==0, ], 'parse-data')
expect_false(methods::is(pd[pd$parent==0, 'id'], 'parse-data'))
}
#' @export
`-.parse-data` <- function(e1, e2){
stopifnot( inherits(e2, 'parse-data')
, inherits(e1, 'parse-data')
)
subset(e1, !(e1$id %in% e2$id))
}
if(FALSE){#@test `-.parse-data`
pd <- get_parse_data(parse(text={
"{# Section Block
#' Roxygen Line Beore
nested <-
function(x){
#' line inside
cat(\"hello world\")
}
}
"
}, keep.source=TRUE))
comments <- nodes(all_comment_ids(pd))
expect_is(comments, 'parse-data')
clean.pd <- pd - comments
expect_is(clean.pd, 'parse-data')
expect_true(!any(comments$id %in% clean.pd$id))
}
#' @export
`sort.parse-data` <- function(x, decreasing=FALSE, ...){
x[do.call(order, append(x, list(decreasing=decreasing))),]
}
if(FALSE){#TODO test for parse-data
pd <- get_parse_data(parse(text={
"{# Section Block
#' Roxygen Line Beore
nested <-
function(x){
#' line inside
cat(\"hello world\")
}
}
"
}, keep.source=TRUE))
sort(pd)
}
#' @export
as.data.frame.parseData <-
function( x, ...){
x <- t(unclass(x))
colnames(x) <- c( "line1", "col1", "line2", "col2"
, "terminal", "token.num", "id", "parent"
)
x <- data.frame( x[, -c(5, 6), drop = FALSE]
, token = attr(x, "tokens")
, terminal = as.logical(x[, "terminal"])
, text = attr(x, 'text')
, stringsAsFactors = FALSE
)
o <- order(x[, 1], x[, 2], -x[, 3], -x[, 4])
x <- x[o, ]
rownames(x) <- x$id
x
}
if(FALSE){#@testing
if(F)
debug(as.data.frame.parseData)
p <- parse(text={"
my_function <- function(object #< An object to do something with
){
#' A title
#'
#' A Description
print(\"It Works!\")
#< A return value.
}"}, keep.source=TRUE)
srcfile <- attr(p, 'srcfile')
x <- srcfile$parseData
df1 <- as.data.frame.parseData(x, srcfile=srcfile)
expect_true(valid_parse_data(df1))
}
# Others ===============================================================
#' @export
valid_parse_data <-
function( df ){
#' @rdname get_parse_data
#' @param df a data.frame object.
#' @description
#' \subsection{valid_parse_data}{
#' The \code{valid_parse_data} function tests if the object \code{df}
#' conforms to the expected conventions of a \code{parse-data} object.
#' Returns TRUE if valid otherwise returns the reason it is not valid.
#' }
if (!inherits(df, "data.frame")) return("Not a data.frame object")
if (!all(.pd.expected.names %in% names(df))) return("names of data do not conform.")
return(TRUE)
}
if(F){#@testing
df <- utils::getParseData(parse(text="rnorm(10,0,1)", keep.source=TRUE))
expect_true (valid_parse_data(df), 'parse-data')
expect_equal(valid_parse_data(datasets::iris ), "names of data do not conform.")
expect_equal(valid_parse_data(stats::rnorm(10,0,1)), "Not a data.frame object")
}
as_parse_data <- function(df){
#' @rdname get_parse_data
#' @description
#' \subsection{as_parse_data}{
#' The \code{as_parse_data} function tests if a data frame is valid through
#' \code{valid_parse_data} then returns the data with the comments
#' classified, as is expected for parse-data objects. All parse data for
#' use with parsetools functions should be obtained either through
#' get_parse_data or converted through as_parse_data.
#' }
is.valid <- valid_parse_data(df)
if (!isTRUE(is.valid)) stop("Cannot convert to parse-data: ", is.valid)
sort(structure( fix_eq_assign(classify_comment(df))
, class=c( 'parse-data', 'data.frame')
))
}
if(FALSE){#@testing
df <- utils::getParseData(parse(text="rnorm(10,0,1)", keep.source=TRUE))
expect_is (as_parse_data(df), 'parse-data')
expect_error(as_parse_data(datasets::iris), "Cannot convert to parse-data: names of data do not conform.")
expect_error(as_parse_data(stats::rnorm(10,0,1)), "Cannot convert to parse-data: Not a data.frame object")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.