parsetools/0000755000176200001440000000000013643376012012452 5ustar liggesusersparsetools/NAMESPACE0000644000176200001440000000134413643165753013703 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("-","parse-data") S3method("[","parse-data") S3method(as.data.frame,parseData) S3method(get_parse_data,"function") S3method(get_parse_data,default) S3method(get_parse_data,srcfile) S3method(get_parse_data,srcref) S3method(pd_identify,"NULL") S3method(pd_identify,default) S3method(pd_identify,srcref) S3method(sort,"parse-data") S3method(strip_doc_comment_leads,character) S3method(strip_doc_comment_leads,data.frame) S3method(subset,"parse-data") export(extract_test_block) export(extract_test_blocks) export(get_parse_data) export(pd_get_comment_tag_content) export(pd_identify) export(strip_doc_comment_leads) export(valid_parse_data) exportPattern("^pd_.*") parsetools/man/0000755000176200001440000000000013471277762013240 5ustar liggesusersparsetools/man/all_grouping_ids.Rd0000644000176200001440000000061013643165754017043 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grouping.R \name{all_grouping_ids} \alias{all_grouping_ids} \title{get the grouping ids} \usage{ all_grouping_ids(pd = get("pd", parent.frame())) } \arguments{ \item{pd}{The \code{\link{parse-data}} information} } \value{ an integer vector of ids. } \description{ get the ids that represent the grouping nodes. } parsetools/man/pd_is_comment.Rd0000644000176200001440000000215113643122162016326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/comments.R \name{pd_is_comment} \alias{pd_is_comment} \alias{pd_is_relative_comment} \alias{pd_all_relative_comment_ids} \alias{pd_is_doc_comment} \title{Is this a comment?} \usage{ pd_is_comment(id, pd, .check = TRUE) pd_is_relative_comment(id, pd, .check = TRUE) pd_all_relative_comment_ids(pd) pd_is_doc_comment(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \value{ Should return a logical vector, for parse-data and data.frame should be length of \code{nrow(x)}. For character same length as x. } \description{ \subsection{pd_is_comment}{ Test if an id represents a comment of any kind. } \subsection{pd_is_relative_comment}{ Tests if the comment is a relative (location dependent) type comment. } \subsection{pd_all_relative_comment_ids}{ Retrieve all ids associated with relative comments. } \subsection{pd_is_doc_comment}{ Additionally tests if the comment is a documentation type comment. } } parsetools/man/pd_all_tagged_iff_block_ids.Rd0000644000176200001440000000163113643122163021114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iff_blocks.R \name{pd_all_tagged_iff_block_ids} \alias{pd_all_tagged_iff_block_ids} \title{Find all tagged \code{if(FALSE)} blocks.} \usage{ pd_all_tagged_iff_block_ids(pd, tag, doc.only = TRUE) } \arguments{ \item{pd}{The \code{\link{parse-data}} information} \item{tag}{The tag to consider.} \item{doc.only}{Should comments be restricted to documentation style comments only?} } \value{ an integer vector giving the ids in \code{pd} that identify \code{\link[=iff-blocks]{if(FALSE)}}\link[=iff-blocks]{ blocks} that are also tagged with \code{tag}. } \description{ Retrieves all ids identifying \code{\link[=iff-blocks]{if(FALSE)}} blocks that are also tagged with \code{tag}. See \code{\link{pd_is_tagged_iff_block}} for details. } \seealso{ \code{\link{pd_is_iff_block}}, \code{\link{pd_is_tagged_iff_block}}, \code{\link{pd_has_tag}} } parsetools/man/if-statements.Rd0000644000176200001440000000440313643122170016272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_if.R \name{if-statements} \alias{if-statements} \alias{pd_is_if} \alias{pd_get_if_predicate_id} \alias{pd_get_if_branch_id} \alias{pd_get_if_alternate_id} \title{If Statement Nodes} \usage{ pd_is_if(id, pd, .check = TRUE) pd_get_if_predicate_id(id, pd, .check = TRUE) pd_get_if_branch_id(id, pd, .check = TRUE) pd_get_if_alternate_id(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \value{ an id integer. an id integer. } \description{ These function navigate logic statements. Returns the id of the predicate of the if statement, i.e. the conditional statement. Returns the id of the body of the branch executed if the predicate evaluates to true. Gets the id of the alternate branch, i.e. the else branch. } \details{ If statements have the form of the following.\preformatted{ if (predicate) branch else alternate } The \code{predicate} refers to the logical test being performed. The \code{branch} is the statement or block that is executed if \code{predicate} evaluates true. The \code{alternate} is the statement of block that is executed if \code{predicate} returns false. } \section{Functions}{ \itemize{ \item \code{pd_is_if}: Is node an if expression. \item \code{pd_get_if_predicate_id}: Get the predicate node. \item \code{pd_get_if_branch_id}: Get the \code{branch} statement or block node. \item \code{pd_get_if_alternate_id}: Get the \code{alternate} statement or block node. }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) # Find the if statement is.if <- pd_is_if(pd$id, pd=pd) sum(is.if) if.id <- pd$id[is.if] # The predicate pd_reconstitute(pd_get_if_predicate_id(if.id, pd), pd) # The branch for if predicate evaluates TRUE pd_reconstitute(pd_get_if_branch_id(if.id, pd), pd) # The alternate for if predicate evaluates FALSE pd_reconstitute(pd_get_if_alternate_id(if.id, pd), pd) } parsetools/man/get_family_pd.Rd0000644000176200001440000000154713643122163016322 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/family.R \name{get_family_pd} \alias{get_family_pd} \title{Get family of nodes.} \usage{ get_family_pd( id, pd, include.self = TRUE, ngenerations = Inf, ..., include.doc.comments = TRUE, include.regular.comments = FALSE ) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{include.self}{Should the root node (\code{id}) be included?} \item{ngenerations}{Number of generations to go forwards or backwards.} \item{...}{currently ignored.} \item{include.doc.comments}{include associated documentation comments.} \item{include.regular.comments}{include associated regular comments.} } \value{ a subset of the \code{\link{parse-data}} \code{pd}. } \description{ Subset the \code{pd} to the family of \code{id}. } parsetools/man/assignments.Rd0000644000176200001440000000430613643122165016050 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_assign.R \name{assignments} \alias{assignments} \alias{pd_is_assignment} \alias{pd_get_assign_value_id} \alias{pd_get_assign_variable_id} \title{Assignment Node Navigation.} \usage{ pd_is_assignment(id, pd, .check = TRUE) pd_get_assign_value_id(id, pd, .check = TRUE) pd_get_assign_variable_id(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \description{ These function help identify and navigate assignments in parse data. } \details{ These functions only deal with assignment operators. Using \code{\link[base:assign]{base::assign()}} or \code{\link[base:delayedAssign]{base::delayedAssign()}} are considered calls in terms of parse data. There are five assignment operators grouped into three categories. \itemize{ \item Left assignment, the \code{\link[base:assignOps]{<-}} and \code{\link[base:assignOps]{<<-}}, \item right assignment, \code{\link[base:assignOps]{->}} and the rarely used \code{\link[base:assignOps]{->>}} \item and the equals assignment \code{\link[base:assignOps]{=}}. } } \section{Functions}{ \itemize{ \item \code{pd_is_assignment}: Check if the node is an assignment expression. \item \code{pd_get_assign_value_id}: Get the id for the value portion of an assignment. \item \code{pd_get_assign_variable_id}: Get the variable of an assignment. }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) # The first should be an assignment pd_is_assignment(roots[[1]], pd=pd) # the variable/value of the assignment can be accessed by variable.id <- pd_get_assign_variable_id(roots[[1]], pd) value.id <- pd_get_assign_value_id(roots[[1]], pd) # Note that these function will give the variable/value part # for both LEFT_ASSIGN and RIGHT_ASSIGN operators, going by order # of ids, or position in the data may not give the expected results. } parsetools/man/pd_identify.Rd0000644000176200001440000000151613643122167016015 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_identify.R \name{pd_identify} \alias{pd_identify} \alias{pd_identify.default} \alias{pd_identify.NULL} \alias{pd_identify.srcref} \title{Get the ID for an object} \usage{ pd_identify(pd, object) \method{pd_identify}{default}(pd, object) \method{pd_identify}{`NULL`}(pd, object) \method{pd_identify}{srcref}(pd, object) } \arguments{ \item{pd}{the parse data.} \item{object}{an object that originated in pd, for which to obtain the ID.} } \description{ Identify in pd the id for the object given. } \section{Methods (by class)}{ \itemize{ \item \code{default}: Default method identifies by \code{\link[base:srcref]{base::srcref()}}. \item \code{NULL}: Passing a NULL object will result in an error. \item \code{srcref}: Identify by explicit \code{srcref}. }} parsetools/man/internal.Rd0000644000176200001440000000625313643122162015331 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/internal.R, R/accessors.R \name{internal} \alias{internal} \alias{token} \alias{text} \alias{nodes} \alias{start_line} \alias{start_col} \alias{end_line} \alias{end_col} \alias{filename} \alias{lines} \alias{is_terminal} \alias{is_first_on_line} \alias{is_last_on_line} \alias{spans_multiple_lines} \alias{terminal_ids_on_line} \alias{ids_starting_on_line} \alias{ids_ending_on_line} \alias{prev_terminal} \alias{expr_text} \title{Make a function operate internal to parsetools} \usage{ internal(fun, id = pd$id) token(id = pd$id, pd = get("pd", parent.frame())) text(id = pd$id, pd = get("pd", parent.frame())) nodes(id, pd = get("pd", parent.frame())) start_line(id, pd = get("pd", parent.frame())) start_col(id, pd = get("pd", parent.frame())) end_line(id, pd = get("pd", parent.frame())) end_col(id, pd = get("pd", parent.frame())) filename(pd = get("pd", parent.frame())) lines(id, pd = get("pd", parent.frame())) is_terminal(id, pd = get("pd", parent.frame())) is_first_on_line(id, pd = get("pd", parent.frame())) is_last_on_line(id, pd = get("pd", parent.frame())) spans_multiple_lines(id, pd = get("pd", parent.frame())) terminal_ids_on_line(line, pd = get("pd", parent.frame())) ids_starting_on_line(line, pd = get("pd", parent.frame())) ids_ending_on_line(line, pd = get("pd", parent.frame())) prev_terminal(id = pd$id, pd = get("pd", parent.frame())) expr_text(id, pd = get("pd", parent.frame())) } \arguments{ \item{fun}{The function to make internal} \item{id}{the ID of the expression} \item{pd}{the parse data.} \item{line}{a line number} } \description{ Convert a function to look for pd object in the \code{parent.frame()}, and the id to extract from the pd unless overwritten. These functions are for internal use but are documented here for reference. } \section{Functions}{ \itemize{ \item \code{token}: Extract the token \item \code{text}: Extract the text \item \code{nodes}: Extract only the specified node(s). \item \code{start_line}: Get the line the expression starts on. \item \code{start_col}: Get the column the expression starts on. \item \code{end_line}: Get the line the expression ends on. \item \code{end_col}: Get the column the expression ends on. \item \code{filename}: Extract the filename if available, otherwise return "". \item \code{lines}: Extract the lines of text. \item \code{is_terminal}: does id represent a terminal node. \item \code{is_first_on_line}: is an expression the first one on a line? \item \code{is_last_on_line}: Is expression the last terminal node on the line? \item \code{spans_multiple_lines}: does the expression span multiple lines? \item \code{terminal_ids_on_line}: Get the ids on a given line that are terminal nodes. \item \code{ids_starting_on_line}: Get ids for nodes that start on the given line \item \code{ids_ending_on_line}: Get ids for nodes that end on the given line \item \code{prev_terminal}: Get the id for the terminal expression that is immediately prior to the one given. \item \code{expr_text}: If id represents an \code{expr} token reiterate on the firstborn. Throws an error if anything but an expression or text if found. }} parsetools/man/n_children.Rd0000644000176200001440000000060113643165754015627 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/children.R \name{n_children} \alias{n_children} \title{Count the number of children} \usage{ n_children(id = pd$id, pd = get("pd", parent.frame())) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} } \description{ Count the number of children } parsetools/man/extract_test_blocks.Rd0000644000176200001440000000066313643165755017601 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/testing_blocks.R \name{extract_test_blocks} \alias{extract_test_blocks} \title{extract tests from a file.} \usage{ extract_test_blocks(file) } \arguments{ \item{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}}. } parsetools/man/extract_test_block.Rd0000644000176200001440000000133413643122174017376 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/testing_blocks.R \name{extract_test_block} \alias{extract_test_block} \title{Extract testing blocks from the parse-data.} \usage{ extract_test_block( id = all_tagged_iff_block_ids(pd, .testing.tags), pd = get("pd", parent.frame()) ) } \arguments{ \item{id}{iff block id, not the content} \item{pd}{a \link{parse-data} object.} } \value{ a character vector with the lines for the specific test(s) with the name of the test included as an attribute. } \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. } parsetools/man/pd_get_comment_tag_content.Rd0000644000176200001440000000101113643122174021054 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{pd_get_comment_tag_content} \alias{pd_get_comment_tag_content} \title{Get the content of a tag} \usage{ pd_get_comment_tag_content(id, pd, tag, all.contiguous = FALSE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{tag}{tag(s) to test for} \item{all.contiguous}{if TRUE get all comments connected to this element.} } \description{ Get the content of a tag } parsetools/man/pd_get_closest_call_id.Rd0000644000176200001440000000116113643122167020160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_classes.R \name{pd_get_closest_call_id} \alias{pd_get_closest_call_id} \title{Get the closest call ID.} \usage{ pd_get_closest_call_id(id, pd, calls = NULL, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{calls}{optional calls to limit consideration to.} \item{.check}{Perform checks for input validation?} } \description{ Get the id of the call that is closest to the \code{id} given. Closest is defined as the innermost call that contains the \code{id}. } parsetools/man/accessors.Rd0000644000176200001440000000074513643165754015520 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/accessors.R \name{pd_text} \alias{pd_text} \alias{pd_token} \alias{pd_start_line} \alias{pd_end_line} \alias{pd_filename} \alias{pd_start_col} \alias{pd_end_col} \title{Accessor functions} \usage{ pd_text(id, pd) } \arguments{ \item{id}{the ID of the expression} \item{pd}{the parse data.} } \description{ This collection of function can be used to easily access elements of the parse data information. } parsetools/man/function-nodes.Rd0000644000176200001440000000636413643122167016460 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_function.R \name{function-nodes} \alias{function-nodes} \alias{pd_is_function} \alias{pd_is_in_function} \alias{pd_get_function_body_id} \alias{pd_get_function_arg_ids} \alias{pd_get_function_arg_variable_ids} \alias{pd_get_function_arg_variable_text} \alias{pd_is_function_arg} \alias{pd_get_function_arg_associated_comment_ids} \title{Function Nodes} \usage{ pd_is_function(id, pd, .check = TRUE) pd_is_in_function(id, pd, .check = TRUE) pd_get_function_body_id(id, pd, .check = TRUE) pd_get_function_arg_ids(id, pd, .check = TRUE) pd_get_function_arg_variable_ids(id, pd, .check = TRUE) pd_get_function_arg_variable_text(id, pd, .check = TRUE) pd_is_function_arg(id, pd, .check = TRUE) pd_get_function_arg_associated_comment_ids(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \description{ These function help identify and navigate noses associated with function definition. } \details{ A function node is the node for the expression that has as it's children the function keyword(firstborn), the arguments, including the nodes representing the opening closing parentheses in the definition, and finally a node, as the youngest, for the body of the function. } \section{Functions}{ \itemize{ \item \code{pd_is_function}: Test if the \code{id} points to a function. \item \code{pd_is_in_function}: test if a node is contained in a function definition. \item \code{pd_get_function_body_id}: Obtain the body of a function \item \code{pd_get_function_arg_ids}: Obtain the ids for the arguments of a function \item \code{pd_get_function_arg_variable_ids}: Retrieve the variable for a function argument \item \code{pd_get_function_arg_variable_text}: Get the variable names for a function definition. \item \code{pd_is_function_arg}: is \code{id} a function argument? \item \code{pd_get_function_arg_associated_comment_ids}: Retrieve relative documentation comments associated with function arguments. }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) function.id <- pd_get_assign_value_id(roots[[1]], pd) pd_is_function(function.id, pd) length(function.kids <- pd_get_children_ids(function.id, pd)) # function nodes have many because it contains # 1. the function keyword. # 2. the parentheses '(' and ')' # 3. each argument name plus the equals sign and value, if given. # 4. and finally, and expr node for the function body. pd_token(function.kids, pd) # even though there are only two argument since each has # a default value given there are 6 total nodes that # return true as function arguments, care is needed when # dealing with function arguments. pd_is_function_arg(function.kids, pd) pd_get_function_arg_ids(function.id, pd) # A simple way to identify the argument names is pd_get_function_arg_variable_text(function.id, pd) # To identify the function body node. pd_get_function_body_id(function.id, pd) } parsetools/man/get_parse_data.Rd0000644000176200001440000000534013643122163016454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_parse_data.R \name{get_parse_data} \alias{get_parse_data} \alias{parse-data} \alias{get_parse_data.srcfile} \alias{get_parse_data.srcref} \alias{get_parse_data.function} \alias{valid_parse_data} \alias{as_parse_data} \title{Parse Data} \usage{ get_parse_data(x, ...) \method{get_parse_data}{srcfile}(x, ...) \method{get_parse_data}{srcref}( x, ..., ignore.groups = TRUE, include.doc.comments = TRUE, include.regular.comments = FALSE ) \method{get_parse_data}{`function`}(x, ...) valid_parse_data(df) as_parse_data(df) } \arguments{ \item{x}{an object to get parse-data from.} \item{...}{options for specific type of objects.} \item{ignore.groups}{Should \link[=pd_is_grouping]{groupings} be ignored?} \item{include.doc.comments}{include associated documentation comments.} \item{include.regular.comments}{include associated regular comments.} \item{df}{a data.frame object.} } \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 \verb{} 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. \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. } \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. } } \section{Methods (by class)}{ \itemize{ \item \code{function}: Get parse information from a function. The function must have a \code{\link[base:srcref]{srcref}}. }} \examples{ 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) tools::assertError(get_parse_data(rnorm), verbose = TRUE) } parsetools/man/clean_tag_comments.Rd0000644000176200001440000000052213643165755017347 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{clean_tag_comments} \alias{clean_tag_comments} \title{clean tag comments} \usage{ clean_tag_comments(x, tag) } \arguments{ \item{x}{text to strip from} \item{tag}{tag(s) to remove} } \description{ replaces '\code{#@tag}' with '\code{#! @tag}' } parsetools/man/pd_get_tagged_comment_ids.Rd0000644000176200001440000000117713643122174020656 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{pd_get_tagged_comment_ids} \alias{pd_get_tagged_comment_ids} \title{Get tagged comment ids} \usage{ pd_get_tagged_comment_ids(pd, tag, doc.only = TRUE) } \arguments{ \item{pd}{The \code{\link{parse-data}} information} \item{tag}{tag(s) to test for} \item{doc.only}{Restrict to documentation comments only?} } \value{ an integer vector of ids. } \description{ Finds all ids that are comments and contain the given '@' \code{tag}. If doc.only is true(default) then only documentation comments are considered, otherwise all comments are examined. } parsetools/man/iff-blocks.Rd0000644000176200001440000000570513643122163015536 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iff_blocks.R \name{iff-blocks} \alias{iff-blocks} \alias{pd_is_iff} \alias{pd_is_iff_block} \alias{pd_all_iff_ids} \alias{pd_all_iff_block_ids} \alias{pd_is_tagged_iff_block} \title{IFF Blocks} \usage{ pd_is_iff(id, pd, allow.short = TRUE, .check = TRUE) pd_is_iff_block(id, pd, allow.short = TRUE, .check = TRUE) pd_all_iff_ids(pd = get("pd", parent.frame()), ...) pd_all_iff_block_ids(pd, root.only = TRUE, ignore.groups = FALSE, ...) pd_is_tagged_iff_block(id, pd, tag, doc.only = TRUE, ..., .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{allow.short}{if \code{if(F)} should be considered an IFF block.} \item{.check}{Perform checks for input validation?} \item{...}{passed along.} \item{root.only}{only root blocks(\code{TRUE}) or all block (\code{FALSE})} \item{ignore.groups}{Ignore code grouping} \item{tag}{The tag to consider.} \item{doc.only}{Should comments be restricted to documentation style comments only?} } \description{ IFF is short for \verb{if(FALSE)\\\{#@tag ...} blocks. These block can contain development, testing, or example code that can be extracted into documentation or other files. } \details{ Here are some examples: \itemize{ \item \verb{if(FALSE)\\\{#' @test ...} Is valid and tags the block as a test. \item \verb{if(FALSE)\\\{#@test ...} Is valid and tags the block as a test. Note here that we are using the \verb{#@} tag comment. \item \verb{if(FALSE)\\\{# @test ...} Is valid only if \code{doc.only==FALSE}. \item \verb{if(FALSE)#@test ...} } } \section{Functions}{ \itemize{ \item \code{pd_is_iff}: This function tests if an expression id is the root of an \code{if(FALSE)} statement, differs from \code{pd_is_iff_block} in that it will return TRUE even if the conditional statement is not a formal bracketed block \code{{...}}. \item \code{pd_is_iff_block}: Tests if an expression id is the root of an \code{if(FALSE)} block statement, differs from \code{pd_is_iff} in that in addition to it being an \verb{if(FALSE)} expression the conditional branch of the logic must be a braced block of code. E.g. if given the id corresponding to \code{if(FALSE){...}}, both \code{pd_is_iff()} and \code{pd_is_iff_block()} would return TRUE while for \code{if(FALSE)do_somthing()} \code{pd_is_iff()} would return TRUE but \code{pd_is_iff_block()} would return FALSE because the expression is not a 'block' statement. \item \code{pd_all_iff_ids}: Get all ids corresponding to IFF expressions. \item \code{pd_all_iff_block_ids}: Get all ids corresponding to IFF block \item \code{pd_is_tagged_iff_block}: Test if a block if both an IFF block statement and is tagged. To tag an IFF block the first pared element must be a comment that contains an '@' tag to denote a special block. The comment on the same line as the opening brace or on any subsequent line but cannot be preceded by any other statement. }} parsetools/man/calls.Rd0000644000176200001440000000460413643122165014614 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_call.R \name{calls} \alias{calls} \alias{pd_is_call} \alias{pd_is_symbol_call} \alias{pd_get_call_symbol_id} \alias{pd_get_call_arg_ids} \title{Call nodes} \usage{ pd_is_call(id, pd, calls = NULL, .check = TRUE) pd_is_symbol_call(id, pd, .check = TRUE) pd_get_call_symbol_id(id, pd, .check = TRUE) pd_get_call_arg_ids(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{calls}{an optional list of calls to restrict consideration to.} \item{.check}{Perform checks for input validation?} } \value{ a logical of the same length as \code{id} a named list where each element is the id for the \code{expr} element of the argument. } \description{ Call nodes represent function calls. Retrieves the ids of the arguments of a call as an integer vector. } \details{ The traditional call of \code{function_name(arguments)} is a symbol call as \code{function_name} is the symbol directly referencing the function to call. Other calls may exists such as \code{function_array[[1]]()} which first indexes the \code{function_array} then calls the returned function. This qualifies as a call expression but not a symbol call expression. We are often only concerned with symbol calls and not the anonymous version. } \section{Functions}{ \itemize{ \item \code{pd_is_call}: Test if the node is a call expression. \item \code{pd_is_symbol_call}: Test if the node is specifically a symbol call expression. \item \code{pd_get_call_symbol_id}: Get the symbol, i.e. the name of the function, being called. \item \code{pd_get_call_arg_ids}: test Get the set of arguments to the function call. }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) # which root is a call? pd_is_call(roots, pd) id <- roots[pd_is_call(roots, pd)] # not all calls are symbole calls. pd_is_symbol_call(id, pd) # what is the symbol being called? pd_text(pd_get_call_symbol_id(id, pd), pd) # what are the arguments to the call args <- pd_get_call_arg_ids(id, pd) pd_token(pd_get_firstborn(args, pd), pd) pd_text(pd_get_firstborn(args, pd), pd) } parsetools/man/figures/0000755000176200001440000000000013375322555014676 5ustar liggesusersparsetools/man/figures/logo.png0000644000176200001440000004676013375322626016360 0ustar liggesusersPNG  IHDRyXsBIT|d pHYsv`FtEXtSoftwarewww.inkscape.org< IDATxwE>TuO؜3&HŌq\1 wY3rYSD FDT@X,,lqf"I_azya\tEΆ7\9}5kn!/c1 @/YNLLtnOn/)7SV ۷ח 80p0zqQ-.k޽{J d,cl6Zң2z hGPk>ܱc_ѿ9==}BJOowMch--/jp_+߆rz]Y p8`2cc 1G#ӮO( /\kkw7lPw:+$qY$$ s''u-h,(/Rco+YYY{mpｈv[թ]v}rn =\.2C2i}/vCoŋAJ;g⊝;wb7?O_ d!rd<8䠠_ |_DS gffqNqgL ~mjs..Ӊ~f嗟SLj_zM]GI:W_!m;vy%D=1?f ͟.˝]~njKz8L|E$v/_q yEBkhrqίضmsnyU(cC)ւ=0eD0;DQgNl݊RT݋))cܸ0amd8ֲ2)B CF"??,5? aæ'$$l$lkBBr`yo#pOV_ħ!41Ș1݆#Gu''r!GH&NDޱJ1MޓXWZZw4?TRfCiys(P`ƆGE̙IH~S]x$^8QzaMl{ҥ8[RrEQ'RG 0 8##c$Ia1`ܚ5pɖ-X7w.j Ϻ-\a>WrFDtx][]aGM^k֠Wh"$Ǭ #G<놟j ?t:kcW[Uspr2F2}n [_}:MMXzxoXȇyg-D('3KCR]q_afa\1n"vWdee_iq9)11qcl",`wn|&1EEH3͛_x̗3ws3Yҝ; CѣHQsiwPU u$t4 *7j[Qd&$$٥Kc'Ow֝8 fRvvv]k沌SbՈv׵v!6.XSVfYs=x}P,6xZZ0'+W’q|˖v GG>'rsO^Æå1…333 y.rfddrkf iir%qGǧMܐ޽iU磡8ȑ([l~Hv;\ +G7˧Oǻc`%}ϔnU_9ߛYϞ=C϶Oy933Z-ֺ0ꭷ0~6ׯǰ;@"Wb{asϝS[8G+@pK/ 6 d_o{  !=A=}tFN'2}9Bz1"4442++sꜟ*--m$IA*YzH¸'y|r-ɨܿqql蒪)SPwص -55_ iӦA4c8y3Yo470~+@>U*ˤI0w.pv܌={Z[2cܹӖz ;w⺏?Ʀ;0}o~ٶQo1cs|-ڥ {}aM7ֵ;p75!g3+Pq#63L$*#K1͆z{fff=1f^ 1ꭷ`@$$7@xr2Joj8y]t{q8BBJ|C5-UU/-P {|5XrzGedd:zOj ʴKA*ǭy"o1m:sEb :y3%HqӌV,87n\UfnڤizWM/_oa\9rd&bGF%SIma!+*Pw/3<.~AD0c"{q9۔Ф$bD)lv^8~nQ2?} ̙3Qj)NSDŽeL1|B$O|NIW_yȞ=ToDTϞdtx:%IEHR` &t3!"0F >=u\inƏwf͕(߽۴\{>)ݵ 11fqؑ#4q"탫zzvWbbbɓ'?6C&geeHDIBC1h<Ď}^:t*Qn=1ۍ)+M"@uǎL0A?>m]w 4H$% `KKyHBP_&3֚|!ӾaO/l+. 'Nß}CSe/, xJ4yQ ϩEO]9srss_Ç_`,{,#k0ԭLꋊh?q+043,LtV6<}׻u;館޽+,䶠 `IBJJxO?I)U3Q5Gb6d4)S]#GdW?"l^v`7 FG "X0HHN'j1C.ƘU?~xq 劢Y"ϣ4z=v&WX׮ #RI"8D]q1A7ĉmsGv{ZZx*(QWeӦ\F9q搄A5|rwQQ㝇7T a&,RY7FG'c`HH>1o_gS|ReڝH򬬬1v5,LRI>8*Sc Ro]g;cA AK\?<(˲ @MrM[fĝw6S P{Od.quz/efP5 <\3&]42@`t4HUqtz,>;jVBhRdYY;e=M^H/ x^&!s"i38鎏 "bX1co>&y c&}wj yرm&#Kqq* _."5PR"q΍8io#@P|y6X3h1DDcQza@O?!c Zw{! 9OG0ꭷ:Ejca=y_`~ BQԍO>3FR@m3?^~"GW\xaX34)DJ*9J|ZZ[xJA@p\&lҏ3]C\kHHK3<ӻHVHYiH2GV1~g DH WD[]Xv-c7r8\)MJ:ToJ=]we|-36u֭uĈ6GXGsƿ[zev睱Nm얓TZ gHJD dSSB0ҶX"m2q`P8FIC7rO>i\8'fFʕz+E0U'^>nlHRVgy-.BݿlɭJmt>.3 -J[ Շu1য়@0@NB: ~~LYۦ#~7X h}}ws3?<(ٲUeSUb H/~A>8i1}b-(HM>y /8G/5۰NB@hb% HI).eaDDQ[Pp[CTTsmDD+1F]Fhi9KՆG=iR#3$Ơ@r:h[Z= 0F1s&0h!Xa Q[P]էBwo׃2.Ncӕ_ d-4ԠØH:T箆niȔN3h_~i9aBK.ܱö ݚUW=,+s^x ۽vMۃCB#SܞV۾F͛WcE^"fhj[]ĉӾ34TPD8gÓU#lpv unjb{?nzM@PL #_|(X7w.zOG[2H~q ehݣ8FΘ4n/njb))nGuc]ڷ;"w(E!,2 v\@(6TW,:dw\7t?еtqb_w1B1@ԍ DU;~xqOz"!-N?f$< ؘtG' )(eM[0l6͝\伇Pl0YcC gޤƗ NIgB Ȁ2F3[TBiDU p@bdN `] Awt=|xk.q77K1DjŁrO?9wnX믇{\.odIc^⋥`޽{ԩz>~5~P`tzocddl2ٴ^ |. ;9fV{M(,HAlK@438 6D k =o ( F``hSPݺCLa <_{-~mpz…C`mA}{%@_\d1tf.j5o^E:=?Lf֔%}_~bRy38$5mُ7PE#T jPD5xԓ8 1$FH69d {, k8~ܖ1sfd 8'wCˆ !TUTTVks;~`A8eh-sh>Cuu6r>H}=Fa geUhK.LKhVUHU {TK9v 1@ u{]r "{hcEsv ;v j,+sUĈ!<`9~"t zIx/b`lU6qeR.t#2t٥أ{Bf0RMԈڶMPD#Cb́n,{*»woݻIgZgc닋ꊊ[kkxeusVDFDKKJ\ /n%U3gEap#4."I3se/wś7d-c늊Շk }mvf!K  Ium D3Tj"N4E4@6/AB`azI\c #!; ?T@x{lꖓS ILtg̜Y V%%G($1?dHKY^^pPfh+N'M֢ɀw> f*6r~oF !DUm;fEăs=ǠG*Z] KA A.*"ܢ 0> ׷׿6=\PfL)NoJ4s!81fh;Q7,[vKI6.,9 7 :9 :Zѓ&^j[mj,)H3FpY>bBqT+`1cF]̙p=F6jT9sJ~|@Bw: p+u 3y\l@fZ}k}QQÆT8 W}` 4Ą 0f$!!0%㷿޻xqDۤ\RdʈٳnٸpZrF n7Nlۆaʕx;ptMP=z!%%fw4޷҂Ȕ}DqŗKᮣ|Q}%bm=0P F\sPN10"zy qw=|d*  q#9\;F\ħ3g&tk,b{]F O[mȌ1l~%:fO*afv5JN۶oz3~-6*!窰8\1uܹ'GΝ[b#IR*l$څv IDAT-ջm `?lp8ʹr#*ZgYrowzĬm>,$`.D@_yDF>N8#"D2~7T6~Vg2h<} I( zJY%C য় ޽-gʀ(Z'H#͊2O|JMuB/(j3dzJKX $pph%J*Us]:wޙ;_g Z ѡn7[vmqqUs ǔ8Yvhc}T}=ugzX@ߴPgjVGTTP̀jl5OC}fuaIIn{/[Gdu^[ܥDb…_x{ u~!Ped t - \f< Ax g*A~UyɄcUwRwѻ]Zz-Bܗ>|yUP~}К?)fL_}V^|14٨QPt1} o^.Çצ\xa$ma]wUA#-KߡcCL\b&εծȐxTr$&AbH<2 M GbЭ bڎ<ZPS.Sf7/{ׇhVW˟ϛ Mcw)(/nfS$$(!z6 H\aʼn/)a+O6ztlfH$ff6'fd42TUUŒS{>W^yr5TZW=jV}zd3`p9'הg`LFઙsL1$#.j8y *p)3w]Lilc$ xSiȗ_FcLQuEE!]T~:02C@t~.h?΅t iO鄝;3@xë9|X>mȑ-&NlN8ZKz|}ذF[})Rw߅m9E!, lI &1Dgw}j!Py`cvʩupU-jp vsO !cc^[>bE=vm*/NHO~iӦt1I٘`qsOUTU(1#i0Cch;+J:O dMnxo0*ݹS9|ج'ٲ^'6Ę`U @(o)S& <25 Rh6  ZjƢ;I7zv $8Dv dpCcKv_/֭j# ! ϙ1o*K͞q`~]>3KWcՉ1?#RS KO&B|YtgA6 wЇdX}2Ծ'Wrt΀oٵЄ!CzW֭[svK#"l!9`NW@A0݇zNh~ 5Afa:QmMeolƎoWЁ||v5BTJ< @052[}衜檪]kg|QQ*p#7eot򧟂 i t:uX 1@m\ {V32\'ow)#fϮ1'DhVTv/⚇͚Ueذ:BX1GB# CUg0[-A}hB\ Yp ݰǎS~U-nP77Wm^4ꈔW_]8$IR6ێEm-;v#Uպa; ޽^00E@6' +< i'bcd048TH,6mMx%%s+,Aw)ʰ/^Le'XΘX$Ja "H,r:eC~cσяkC\gxjɶm7m kt'srnYvq\P%>:Zڰq#\.۵oh={h5a]!ڶ Ի@:GC`bhnnF<9cBҪ>pdjj5q٭:G\sysUUXɓsfha@!qqmS֖3n,7`@+Ҿjƌ[BZB\ (MF쯖UC2h޷w{l<3u| q=`,o5&,yl~w9U`dKJ7yr緶}}r_G72$#Yhnn7иɼBΓv婽 4"n{9z!yBCm-KOLg.Ky4~FgvQ.B8ON5?n ?i{ O@s3a,'o<ݧӦ]Z[pɳ4覛*mguׁm+7zOTgxˤg6i ᧲-@`}*;Sh A6sOfLQЛ ӵ*A}׽{K.كDS>t(sXɈh} wVSSZL?SNyy>k(c;c\Swonyxe!qq0t`90щu36n\RS9sG̙sejTz@ގeXb3}._u9]f[TlXq߇ĒM7:Zxff艊 u}V%%[4"j/YTi^^Ԡo.v͗hK6ر{=uu\W?LWXpZۜ *5; WΘ14{#}B fO qv,cФ; p Ul=5Y87_fl""!B~ s!70kUZZg~545?.)ɻJUnػel WrT? ULz޷3eCABƙX=ia$05 * p;JuڷNյjAFְ1"M/< 4Gj ̙ÇrcpFD4^tҘ>}|cz#;!ܲ4,5Bjut6[;7ʼneAGw௶fѨ ?^:<>j tul jJLkh1h`6{ <Br{pp?\Vohc 2>ocԡwܱyHTJ/XŸ^ eqx⎩!a '?&u2=Cw`Mb:b|a\Q#ٜ9sЫO_Ȳ6o=(mG-6jT 2p !PUd9#Ri/9x fS Fd:\BNqNŭ^6}Rf-N/TX4fvVQL?:;-7%(ٲļQƍgAd`Cv:ݓ~{eʅVe 0JX%IBO2@HI9t*ec~8W[H%IR*iڛ O`-z[u, A4U#vD:s̵ 0療;d"3_[Տ}`L⋈͛'_y4{#,, onW.5=/ܴU-ae >6{!TιӿSmԨo`)&Ј:T&`{q?[j;|G:obq|Uv wbΘ<:]w>Զn]-7 Ϟ=aሎ|fS&-\ԩ'* 4u`} *LtJ&ƭzvLUUU0I2_ʭ1'-ߡoƹ#6w4Yq1/35&v`K\dC]',(#8u=t׮@ggρDBb" 0I,j7Έ]86hiVnSƍ+wvr cD*TUpIR?Fk6p0)K e }M#YOUC'$뀐ɧb1{řj:#gPo_@ke3s $'w>.~o3gQtj4MBZf ֌&YԱUM1YHeK=Q`XߦCQ &!Ǔ;QҋsBϞٚO0{1wk`7cM >& 6 \e^+U%Ccb_ εZR^/愳zl+~Ƅ{ijLδY1fF%bǞ~:kΞ=u׿?>]` snX֓F$3δ2DN/jIJ##;rsI$$t`5=wmXﯝ2>I- A4cZҵW [+02a43TWK~8G ={18- +/d/~ u[`jvR|1E"8'%dY> bv"!U5ձ&uw+q:X^&cFum9nϘ,ĨSڏ>ߍs86@KMk޼7~*d98VT̡ðb'[o=5f> i UAnjAUUԦjH(JGׯT(J lW"͙"U2UGsIaoU^0R4t܉xBwS˝w7<:{8x#GaO @>x?ۨӜz@,d}"=m|/!IBSLTN YV%}PÇS,BT{$1Ձ5٬YleD9kq0dzئ>wݩ-֖ռ@ߙ~SЮK~o>vaTNV,'M*w[m#hK{ uapK9l$j:%v\]y.!  -;z>3#|1[sl4Yu*lǸs`' +z92=4u+G`hkkCرS>`8v˜8~j|-I>~k̰BQH6/}˯DGB2YV tI$ŤD:&PU_ -δqJ`}g|0V?ך`C =_][iVY),eK: Yu+@I#G6;[6M \lYd vD Bpm0=v✘N!%T/К I"30y@o͆%E:}HG^Uwx33e˖ׯ"k#04bAҁg*$Ss$^ЏAEbFWBQ|6niIݲpaWY@PUs1/8^2cfs^G4? cpFXXSǫ+;E2b:(U]5U@sɀ;2AU! uk&Og-,:g-NohZ+ c8;^h->q>ҷޚ2AQRDu髁 sZ+*4v𲰎ke"NUƵ|Vo]P:vSv̿2o?(e<MM>r笰`84/%Di(#!:-nW5 ZBQ NwaPfߧ̸.StoH{.?|o犘ϤTBHvKEȑBg}II@cee2lW=HKfv֖ʌƎ8L=8Mۅ3"50:5$>5(>ڽ{[t.[hO۬nk/h#eLag3L48pU~vsc9wnh˶o:|80ɐʐHwcc9\u;및h![Eսl׮?V=,mAAuGxx]`ddcp||ChbbsXrrSСu}1I+X/V}< <3smw);T=޷v\eP-"k(-uؼ9|ƲhWmm8鿥t>DDEc]()~+(&&816[>}clH:$ck*ҁ#h׎' wp1޹ elo UIDATdF0_T^n/\>֭EĶ\[Ǚ$.]j"{8ˈuIٍ /1cάb9/[KLn|bϴ1TZ&-QD6UTUHUy]QQt]QQѯg))uCV%0mgIVshimvUj?I`PBگ)T(-C 6O?E5wҹ0I޽ y%uǎmdHdh`L.paPL "P;lM'X_{QH ``jɓ,ɒC~YgO B#F`zaaJ .s=.ծ I[Q[[}uxVV}BGckA@|c ={-dwSY?$К5;v+f lwߟԏmҋ祾D99MneRSqsG5?@fff } ?;1`;'l!!E\ZEY)oy^5@JPLܳ'clc]]ݕGi`-dggp\ N%kՓЄK@ 1:㏁ءA̽ ԻzE|?@1?   gPjÇرc7<":4f = A7?]ma%& ᇀàQf h:O 12R:6mڴ8]oڴ@СCB Ш$9SSqIz翀@CK ˁpO>?t--,+ jP|Ҽ{w@i߫+z4v@Q@CvTp8PkM&؝ : m18/88zBmm-ʠt p: /> 1i-{ `ZZV,]~9} U7w ޻jÇ!1ˁzǽZ$54R ={u,>;k~ s7CG֮dBXE֦}"Ibbbt{;77ͨzTܹA[Gޭ,D޽ӓ|Vؾ}W7qq7tv$7,c06a -$Қti)INRhf H?6m_N[@@_&C4ej :ٮmNLdldIpdI,KӮo{ݽ@_O"'9dFd+r֥(Gyb>? # v&f f {Nꂺz㼾p|X .^K'؆\WU.P*F*++ӟH$RvG}mFkfCCCޝeiӭ'xK(&G>y'Q̥ ݻTW<믅1؆yyayeKT .a~AkP||,vaBb#=S9ykݚi&i`b`Xd X ds3rJ?r 1wWWי ~ܹs---?uKƆ6PVV  gE1r\ӄ' Ob;rB& ȦfbG"4"AoYiN@XAq,#/я .\@9t#?8LƼbG߾-`S~kƍӍlY݈˗'٥1Ͽ.7('^lEw#f]?~<䇬n/HfժUVX>34cWlmԓȵk!BN\B%x1"{@.[f罽VZYll[==0bf|'t-M8lؖ6MIBM EzvnА;74}yݾǃ2iW.EQ=ˇMMM&Hpc[ Qgx<,R>_j ]{=M`=݀btbZ5t8al BT=k1͸n.\2R)i`έ0  \$I;]刺?!rOdB?~0XB$t1 CCCUEUU<6-=m]ȴP~L{n);߸qcl!)3ǧE%R)%ҙTBRp+6xP(@rٌᠪ*EBblmoo~9M$&z&|XD\~fݎIW?Y׊׭[9]I)Saccw- łpg5Mq Jqt:d"1v(ýJd&8.FQBPF"V++$Q7'Ow):H`io8''z;@h4"ibrp:YcB|nTX'̑HK!E$h4J__bQUL"U,$ ZZZ6I)Q4ǬkwlUNN0.~Hֆa$RɄ墢" /p["M_'뻑H8nwF)no9}@NNK"  '& )|-g;9ASS6EQ~-AܩiO"2g<&:i!dR~1Vp 暓XrfLNF t:3Ig#Ȗ|&6椓xG4űi''z*hVGvh֦CJy J)p0>旔AmIENDB`parsetools/man/family-nodes.Rd0000644000176200001440000001102713643122162016077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/children.R, R/firstborn.R, R/parent.R, % R/siblings.R \name{family-nodes} \alias{family-nodes} \alias{pd_get_children_ids} \alias{pd_is_firstborn} \alias{pd_get_firstborn} \alias{pd_get_parent_id} \alias{pd_get_ancestor_ids} \alias{pd_get_sibling_ids} \alias{pd_get_next_sibling_id} \alias{pd_get_prev_sibling_id} \title{Family-wise Node Identification and Navigation.} \usage{ pd_get_children_ids( id, pd, ngenerations = 1, include.self = FALSE, aggregate = TRUE, .check = TRUE ) pd_is_firstborn(id, pd, .check = TRUE) pd_get_firstborn(id, pd, .check = TRUE) pd_get_parent_id(id, pd, .check = TRUE) pd_get_ancestor_ids( id, pd, ngenerations = Inf, aggregate = TRUE, include.self = TRUE, only.present = FALSE, last = 0L, .check = TRUE ) pd_get_sibling_ids(id, pd, .check = TRUE) pd_get_next_sibling_id(id, pd, .check = TRUE) pd_get_prev_sibling_id(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{ngenerations}{Number of generations to go forwards or backwards.} \item{include.self}{Should the root node (\code{id}) be included?} \item{aggregate}{Should aggregate(TRUE) or only the the final (FALSE) generation be returned?} \item{.check}{Perform checks for input validation?} \item{only.present}{should the list be restricted to only those node that are present? Most relevant for when parent is zero.} \item{last}{The last acceptable parent.} } \description{ Parse data is organized into a hierarchy of nodes. These functions provide simple ways to identify the nodes of interest, often from a specified node of interest. Test if an expression is the firstborn, i.e. oldest or lowest id. } \details{ The language parsetools uses is that of family. Similar to a family each node could have: a \dfn{parent}, the node that contains the node in question; \dfn{children}, the nodes contained by the given node; \dfn{ancestors}, the collection of nodes that contain the given node, it's parent, it's parent's parent, and so on; and \dfn{descendents}, the collection of nodes that are contained by the given node or contained by those nodes, and so on. Terminology is analogous, a \dfn{generation} is all the the nodes at the same depth in the hierarchy. A node may have \dfn{siblings}, the set of nodes with the same parent. If a node does not have a parent it is called a \dfn{root} node. Similarly, age is also used as an analogy for ease of navigation. Generally, nodes are numbered by the order that they are encountered, when parsing the source. Therefore the node with the smallest \code{id} among a set of siblings is referred to the \dfn{firstborn}. This is give the special designation as it is the most often of children used, as it likely determines the type of call or expression that is represented by the node. The firstborn has no 'older' siblings, the 'next' sibling would be the next oldest, i.e. the node among siblings with the smallest id, but is not smaller that the reference node id. In all cases when describing function the \code{id}, is assumed to be in the context of the parse data object \code{pd} and for convenience refers to the node associated with said \code{id}. } \section{Functions}{ \itemize{ \item \code{pd_get_children_ids}: Get all nodes that are children of \code{id}. Get all ids in \code{pd} that are children of \code{id}. i.e. lower in the hierarchy or with id as a parent. If \code{ngenerations} is greater than 1 and \code{aggregate} is \code{TRUE}, all descendents are aggregated and returned. \item \code{pd_is_firstborn}: Test if \code{id} is firstborn. \item \code{pd_get_firstborn}: Get the firstborn child of \code{id}. \item \code{pd_get_parent_id}: Get the parent of \code{id}. \item \code{pd_get_ancestor_ids}: Get the ancestors of \code{id}. \item \code{pd_get_sibling_ids}: Identify siblings of \code{id}. \item \code{pd_get_next_sibling_id}: Get the next younger sibling. \item \code{pd_get_prev_sibling_id}: Get the next older sibling. }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) # assignments have three children # The operator, the assignment, and the value. kids <- pd_get_children_ids(roots[[1]], pd) # The token tells what kind of node the ids represent. pd_token(kids, pd) } parsetools/man/root.Rd0000644000176200001440000000406013643122172014473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/root.R \name{root} \alias{root} \alias{root-nodes} \alias{root-ids} \alias{pd_is_root} \alias{pd_all_root_ids} \alias{ascend_to_root} \title{Root IDs} \usage{ pd_is_root(id, pd, ignore.groups = TRUE, .check = TRUE) pd_all_root_ids(pd, include.groups = TRUE) ascend_to_root( id = pd$id, pd = get("pd", parent.frame()), ignore.groups = TRUE, .check = TRUE ) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{ignore.groups}{Should \link[=pd_is_grouping]{groupings} be ignored?} \item{.check}{Perform checks for input validation?} \item{include.groups}{Include groups as root nodes (T) or descend into \link[=pd_is_grouping]{groups} for roots?} } \description{ Root IDs constitute the id of a stand alone expression. That is one that is not contained inside of another call or expression. The one exception to this is code blocks denoted by curly braces that are not themselves part of another call or expression; these we call code groups. In definition, A root node is defined to be a node that either has no parent or whose parent is a grouping node. } \details{ If \code{ignore.groups=TRUE} then groupings are ignored and root nodes within the group are interpreted as roots, otherwise nodes within a group are not interpreted as root. Groupings are always interpreted as root if the parent is 0 or if the parent is a group and also a root. } \section{Functions}{ \itemize{ \item \code{pd_is_root}: Test if a node is a root node \item \code{pd_all_root_ids}: give all root ids in \code{pd} \item \code{ascend_to_root}: ascend from id to root }} \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) } \seealso{ see \code{\link{pd_is_grouping}} for details on what a grouping is. } parsetools/man/pd_is_grouping.Rd0000644000176200001440000000105013643122163016514 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grouping.R \name{pd_is_grouping} \alias{pd_is_grouping} \title{test if an id is a grouping element} \usage{ pd_is_grouping(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \description{ A grouping is defined as a non empty set starting with a curly brace token and and for which there is no parent or the parent is also a grouping. } parsetools/man/pd_get_relative_comment_associated_ids.Rd0000644000176200001440000000215113643122167023430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_comments.R \name{pd_get_relative_comment_associated_ids} \alias{pd_get_relative_comment_associated_ids} \title{Associate relative documentation comments} \usage{ pd_get_relative_comment_associated_ids(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \value{ Returns a vector of the same length as id. Where the value is either the id of the associated object or NA if it cannot be associated. } \description{ Relative comment created with \code{\#\<} comment tags document something designated by the location of the comment. In general, the comment documents the previous symbol. A comment will not be associated with any parse id that does not have the same parent as the comment. For example, } \details{ \preformatted{function(x #< a valid comment )\{\} } would associate \code{a valid comment} with \code{x}, but\preformatted{function(x)\{ #< not a valid comment \} } would not. } parsetools/man/pd_has_tag.Rd0000644000176200001440000000105213643122172015577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{pd_has_tag} \alias{pd_has_tag} \title{Check if there is a documentation \code{@} tag.} \usage{ pd_has_tag(id, pd, tag, ...) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{tag}{tag(s) to test for} \item{...}{options passed on} } \description{ Check if a node of \code{parse-data} identified by \code{id} is both a comment and contains a documentation tag identified by the \code{@} symbol. } parsetools/man/strip_doc_comment_leads.Rd0000644000176200001440000000105113643122162020364 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/comments.R \name{strip_doc_comment_leads} \alias{strip_doc_comment_leads} \title{Remove the characters identifying a documentation comment.} \usage{ strip_doc_comment_leads(comment, rm.space = TRUE) } \arguments{ \item{comment}{The text of the comments or parse data.} \item{rm.space}{should the space at the beginning of the line be removed.} } \description{ Remove the characters identifying a documentation comment as a document comment leaving only the relevant text. } parsetools/man/pd_make_is_in_call.Rd0000644000176200001440000000100413643122165017261 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_make_is_in.R \name{pd_make_is_in_call} \alias{pd_make_is_in_call} \alias{pd_make_is_call} \title{Create a function to test if an id is contained in a type} \usage{ pd_make_is_in_call(calls, .is = pd_make_is_call(calls)) pd_make_is_call(calls) } \arguments{ \item{calls}{The tokens to test against} \item{.is}{A function to test if a specific id is a valid} } \description{ Create a function to test if an id is contained in a type } parsetools/man/strip_tag.Rd0000644000176200001440000000064413643165755015526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tags.R \name{strip_tag} \alias{strip_tag} \title{Remove a tag that identified a line.} \usage{ strip_tag(x, tag, ...) } \arguments{ \item{x}{text to strip from} \item{tag}{tag(s) to remove} \item{...}{passed on options]} } \description{ Removes \code{@tag} tags from the text. Also will remove '\code{#@tag}' replacing with '\code{#!}'. } parsetools/man/all_root_nodes.Rd0000644000176200001440000000114713643122172016516 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/root.R \name{all_root_nodes} \alias{all_root_nodes} \title{Find all root node from parse data} \usage{ all_root_nodes(pd, include.groups = TRUE) } \arguments{ \item{pd}{The \code{\link{parse-data}} information} \item{include.groups}{descend into grouped code \code{\{\}}?} } \value{ \code{\link{parse-data}} with for the root nodes. } \description{ A root node in a file is a standalone expression, such as in source file a function definition. when discussing a subset it is any expression that does not have a parent in the subset. } parsetools/man/pd_class_definitions.Rd0000644000176200001440000001022113643122166017672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pd_classes.R \docType{data} \name{pd_class_definitions} \alias{pd_class_definitions} \alias{pd_is_class_definition} \alias{pd_is_in_class_definition} \alias{pd_add_class_definition} \alias{pd_add_class} \title{Test for Class Definitions} \format{An object of class \code{environment} of length 12.} \usage{ pd_class_definitions pd_is_class_definition(id, pd, .check = TRUE) pd_is_in_class_definition(id, pd, .check = TRUE) pd_add_class_definition( name, test.is, test.in, .exists = TRUE, .overwrite = FALSE ) pd_add_class(name, .exists = TRUE, .overwrite = FALSE) } \arguments{ \item{id}{id(s) to test.} \item{pd}{parse data which contains id.} \item{.check}{should the id, and pd be checked?} \item{name}{name of the class defining function} \item{test.is}{function accepting arguments \code{id} and \code{pd} which tests if given \code{id} is associated with the defined class defining functions.} \item{test.in}{function accepting arguments \code{id} and \code{pd} which tests if given \code{id} is contained in the defined class defining functions.} \item{.exists}{require the function to exists to add.} \item{.overwrite}{if TRUE allows for overwriting existing test functions.} } \description{ These function manage adding class defining functions and testing if an id is associated with a class definition or if is contained in the class definition. } \details{ \subsection{\code{pd_class_definitions$has}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$has(name) }} Check if a class defining function has 'is' and 'in' function defined for it. } \subsection{\code{pd_class_definitions$add} or \code{pd_add_class}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$add(name, .exists=TRUE, .overwrite=FALSE) pd_add_class(name, .exists=TRUE, .overwrite=FALSE) }} Add a def with default 'is' and 'in' functions defined. } \subsection{\code{pd_class_definitions$add_definition} or \code{pd_add_class_definition}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$add_definition(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE) pd_add_class_definition(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE) }} Add a class defining function with custom 'is' and 'in' functions defined. } \subsection{\code{pd_class_definitions$rm}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$rm(name) }} Remove the testing functions for the class. } \subsection{\code{pd_class_definitions$names}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$names() }} Return a vector of the classed for which tests are defined. } \subsection{\code{pd_class_definitions$test_is}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$test_is(id, pd, check=TRUE) }} Test if \code{id} is associated with each of defined class definitions. } \subsection{\code{pd_class_definitions$test_is_in}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$test_is_in(id, pd, check=TRUE) }} Test if \code{id} is contained within each of defined class definitions. } \subsection{\code{pd_class_definitions$which}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$which(id, pd, check=TRUE) }} Return the name of the class, if any, which \code{id} corresponds to. } \subsection{\code{pd_class_definitions$in_which}}{ \subsection{Usage}{\preformatted{ pd_class_definitions$in_which(id, pd, check=TRUE) }} Returns a vector of the classes, if any, of the classes which \code{id} is contained in. } \subsection{\code{pd_is_class_definition}}{ Returns \code{TRUE} if the id corresponds to any of the class defining calls. } } \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) # Get the 'setClass' call. class.id <- pd_get_assign_value_id(roots[2], pd) # Check to make sure that it is a function that sets a class. pd_is_class_definition(class.id, pd) # and that it is the setClass call. pd_text(pd_get_call_symbol_id(class.id, pd), pd) } \keyword{datasets} parsetools/man/pd_get_iff_associated_name_id.Rd0000644000176200001440000000467513643122165021467 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iff_blocks.R \name{pd_get_iff_associated_name_id} \alias{pd_get_iff_associated_name_id} \title{Find the name that should be associated with an \code{if(FALSE)} block.} \usage{ pd_get_iff_associated_name_id(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \description{ For \code{\link[=iff-blocks]{if(FALSE)}} documentation blocks, such as \code{@testing} and \code{@example} blocks, a user may supply an information string which gives the name information for tests and examples. for example, in \verb{if(FALSE)\\\{#@test my special test} the information string is "my special test". The more common case is when there is no information string. In these cases the name is inferred by the previous assignment or declaration. The \code{id} argument should identify one and only one \code{\link[=iff-blocks]{if(FALSE)}} block, but as this is an internal function, argument checks are not performed. } \details{ IFF blocks can be placed sequentially and \code{pd_get_iff_associated_name_id} will navigate back until it finds a non-IFF block to use for the name. This way users can place multiple tests and examples after a declaration. If the previous expression is an assignment, the assignee variable of the assignment is chosen as the name. An attribute 'type' is also set on the return value. For function assignments \code{type="function_assignment"}, for all other assignments \code{type="assignment"}. The names for \code{link{setClass}} calls will also be inferred. The name of the class is taken as the name, but the return value also has the attribute of \code{type="setClass"}. Note that it is common to assign the result of \code{\link{setClass}} to a variable, which may or may not match the class name. In those cases the assignment operation takes priority and would have \code{type="assignment"}. The names for \code{\link{setMethod}} will assume the S3 convention of \code{.}. In the case the the signature is more than just the class, the signature will be collapsed, separated by commas. the type attribute will be set to \code{"setMethod"}. \code{\link{setGeneric}} can also be used with the name of the generic function the inferred name and \code{type="setGeneric"}. \code{\link{setAs}} infers coerce methods. \code{type="setAs"}. } parsetools/man/pd_reconstitute.Rd0000644000176200001440000000147013643122170016723 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/reconstitute.R \name{pd_reconstitute} \alias{pd_reconstitute} \title{Reconstitute Expressions} \usage{ pd_reconstitute(id, pd, .check = TRUE) } \arguments{ \item{id}{id of the expression of interest} \item{pd}{The \code{\link{parse-data}} information} \item{.check}{Perform checks for input validation?} } \description{ Creates expressions and calls from the given \code{id} and parse-data, \code{pd}. } \examples{ # load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) pd_reconstitute(roots[1], pd) } parsetools/DESCRIPTION0000644000176200001440000000255713643376012014171 0ustar liggesusersPackage: parsetools Type: Package Title: Parse Tools Version: 0.1.3 Authors@R: c( person("Andrew", "Redd", , "andrew.redd@hsc.utah.edu", c("aut", "cre")), person("R Consortium", role=c("cph", "fnd")) ) Maintainer: Andrew Redd License: GPL-2 Language: en-US Imports: methods, utils Suggests: covr, knitr, rmarkdown, testthat Description: Tools and utilities for dealing with parse data. Parse data represents the parse tree as data with location and type information. This package provides functions for navigating the parse tree as a data frame. Collate: 'internal.R' 'accessors.R' 'checks.R' 'children.R' 'comments.R' 'errors.R' 'family.R' 'find-utils.R' 'firstborn.R' 'get_parse_data.R' 'grouping.R' 'iff_blocks.R' 'parent.R' 'pd_assign.R' 'pd_call.R' 'pd_make_is_in.R' 'pd_classes.R' 'pd_comments.R' 'pd_function.R' 'pd_identify.R' 'pd_if.R' 'reconstitute.R' 'root.R' 'siblings.R' 'tags.R' 'testing_blocks.R' 'zzz.R' Encoding: UTF-8 RoxygenNote: 7.0.2 VignetteBuilder: knitr KeepSource: yes URL: https://github.com/RDocTaskForce/parsetools BugReports: https://github.com/RDocTaskForce/parsetools/issues NeedsCompilation: no Packaged: 2020-04-07 22:45:53 UTC; u0092104 Author: Andrew Redd [aut, cre], R Consortium [cph, fnd] Repository: CRAN Date/Publication: 2020-04-08 16:30:02 UTC parsetools/build/0000755000176200001440000000000013643201236013544 5ustar liggesusersparsetools/build/vignette.rds0000644000176200001440000000033413643201236016103 0ustar liggesusersmQ 0, 0) ŗ^Dz-Ftm$55tyݍs=]ri 9pnBz 9{Prd%DH8/Ao'FTYhf}1-2#%#z,k|(=}V\0V{(Z#5wòB7z.ԍQ$7?8parsetools/tests/0000755000176200001440000000000013365074730013617 5ustar liggesusersparsetools/tests/testthat/0000755000176200001440000000000013643376012015454 5ustar liggesusersparsetools/tests/testthat/test-family.R0000644000176200001440000000440113615100113020016 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `family.R`') #line 59 "R/family.R" test_that('get_family_pd', {#@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) id <- ascend_to_root(pd[pd$text == 'c','id'], pd) expect_identical(get_family_pd(id, pd), pd[19:24,]) pd <- get_parse_data(parse(text={" # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } "}, keep.source=TRUE)) lid <- pd[match('LEFT_ASSIGN', pd$token), 'parent'] fam <- get_family_pd(lid, pd, include.doc.comments=TRUE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") fam <- get_family_pd(lid, pd, include.doc.comments=TRUE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "#' Documenation before") fam <- get_family_pd(lid, pd, include.doc.comments=FALSE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") fam <- get_family_pd(lid, pd, include.doc.comments=FALSE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "hw") pd <- get_parse_data(parse(text={" #demonstration of grouped code. { # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } }"}, keep.source=TRUE)) group.id <- roots(pd) expect_true(pd_is_grouping(group.id, pd)) id <- expr.id <- roots(pd, FALSE) fam <- get_family_pd(expr.id, pd, include.doc.comments=FALSE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], 'hw') fam <- get_family_pd(expr.id, pd, include.doc.comments=TRUE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "#' Documenation before") fam <- get_family_pd(expr.id, pd, include.doc.comments=TRUE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") }) parsetools/tests/testthat/test-parent.R0000644000176200001440000001054013615106213020036 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `parent.R`') #line 34 "C:/rdtf/parsetools/R/parent.R" test_that('parent', {#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) expect_identical(pd_get_parent_id(1, pd), 3L) expect_is(pd_get_parent_id(1, pd), "integer") expect_is(pd_get_parent_id(10000, pd), "integer", info="missing parent") expect_identical(pd_get_parent_id(10000, pd), NA_integer_, info="missing parent") expect_identical(pd_get_parent_id(pd$id, pd), pd$parent) expect_identical(pd_get_parent_id(0L, pd), NA_integer_) }) #line 86 "C:/rdtf/parsetools/R/parent.R" test_that('ancestors', {#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) id <- pd$id[pd$text=='rnorm'] #< Text ID sym <- parent(id) #< Call identifier ID exp <- parent(sym) #< Root expression id expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=TRUE , include.self=TRUE , only.present = FALSE), c(id, sym, exp,0L), info = "defaults, but fully specified.") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=TRUE , include.self=FALSE, only.present = FALSE), c( sym, exp,0L), info = "include.self=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=TRUE , include.self=FALSE, only.present = FALSE), c( sym, exp ), info = "ngenerations=2, include.self=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=TRUE , include.self=TRUE , only.present = FALSE), c(id, sym, exp ), info = "ngenerations=2, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=FALSE, include.self=FALSE, only.present = FALSE), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 0 , aggregate=FALSE, include.self=TRUE , only.present = FALSE), id , info = "ngenerations=0, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 0 , aggregate=TRUE , include.self=TRUE , only.present = FALSE), id , info = "ngenerations=0, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = FALSE), 0L , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = TRUE ), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids(exp, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = TRUE ), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids(exp, pd, ngenerations=Inf, aggregate=TRUE , include.self=FALSE, only.present = TRUE ), integer(0) , info = "ngenerations= 2, aggregate=FALSE") expect_error(pd_get_ancestor_ids(id, pd, ngenerations= 0, include.self=FALSE)) expect_error(pd_get_ancestor_ids(id, pd, ngenerations= -1)) expect_error( pd_get_ancestor_ids(1:2, pd) , "length\\(id\\) == 1L is not TRUE" ) }) #line 112 "C:/rdtf/parsetools/R/parent.R" test_that('last parameter', {#! @testing last parameter pd <- get_parse_data(parse(text = ' function(){ setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) }', keep.source=TRUE)) root.id <- roots(pd) body.id <- parent(.find_text('{')) id <- .find_text("#< the x field") expect_true(root.id %in% pd_get_ancestor_ids(id, pd)) expect_false(root.id %in% pd_get_ancestor_ids(id, pd, last=body.id)) id2 <- pd[pd$text=="#< the y field", 'id'] expect_error(pd_get_ancestor_ids(c(id, id2), pd, last = body.id, include.self =FALSE)) expect_identical( pd_get_ancestor_ids(id , pd, last = body.id, include.self =FALSE) , ancestors (id2, pd, last = body.id, include.self =FALSE) ) test.object <- pd_get_ancestor_ids(id, pd, last = body.id, include.self =FALSE) expect_false(root.id %in% test.object) }) parsetools/tests/testthat/test-pd_identify.R0000644000176200001440000000155013615100114021036 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_identify.R`') #line 63 "R/pd_identify.R" test_that('pd_identify.srcref', {#@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){} "} source(file = textConnection(text), local=TRUE, keep.source = TRUE ) parsed <- parse(text=text, keep.source=TRUE) pd <- get_parse_data(parsed) id <- pd_identify(pd, my_function) expected <- parent(.find_text('function')[1]) expect_equal(id, expected) expect_error(pd_identify(pd, NULL)) }) parsetools/tests/testthat/test-pd_if.R0000644000176200001440000000131313615100114017616 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_if.R`') #line 121 "R/pd_if.R" test_that('if structures', {#!@testing if structures pd <- get_parse_data(parse(text={" if(predicate){ body } else { alternate } "}, keep.source=TRUE)) id <- roots(pd) # 33 expect_true(pd_is_if(id,pd)) expect_equal(pd_get_if_predicate_id(id, pd), parent(.find_text('predicate'))) expect_equal(pd_get_if_branch_id (id, pd), parent(parent(.find_text('body')))) expect_equal(pd_get_if_alternate_id(id, pd), parent(parent(.find_text('alternate')))) }) parsetools/tests/testthat/test-root.R0000644000176200001440000001254313615100114017527 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `root.R`') #line 71 "R/root.R" test_that('is_root', {#@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) root <- pd$id[pd$parent==0] leaf <- pd$id[pd$parent!=0][1] expect_true (pd_is_root(root, pd)) expect_false(pd_is_root(leaf, pd)) expect_equal(sum(pd_is_root(pd$id, pd=pd)), 1) pd <- get_parse_data(parse(text={'{ x <- rnorm(10, mean=0, sd=1) y <- runif(10) plot(x,y) }'}, keep.source=TRUE)) group.root <- pd$id[pd$parent==0] roots <- children(group.root)[-1] leaf <- .find_text('0') expect_true(pd_is_root(group.root, pd), info="Grouping root") expect_true(pd_is_root(roots[[1]], pd), info="Root within grouping.") expect_equal(sum(pd_is_root(pd$id, pd=pd)), 4) expect_equal(sum(pd_is_root(c(group.root, roots), pd)), 4) expect_false(pd_is_root(leaf, pd)) expect_equal(sum(pd_is_root(pd$id, pd, ignore.groups=FALSE)), 1) expect_error(pd_is_root(0L, pd)) pd[pd$parent %in% c(0,group.root) & pd$token == 'expr', ] expect_false(pd_is_root(roots[[1]], pd, ignore.groups = FALSE)) expect_equal(pd_is_root(c(group.root, roots[[1]]), pd, ignore.groups = FALSE), c(TRUE, FALSE)) pd <- get_parse_data(parse(text={" # a comment outside the grouping {# A grouping #' An Roxygen Comment hw <- function(){ {# Another Grouping # but not a root since it is burried within a function 1+2 #< an expression that is not a root. } 3+4 #< also not a root } 4+5 #< this is a root expression } 6+7 #< a regular root expression "}, keep.source=TRUE)) id <- max(pd[pd$token =="'{'", 'parent']) expect_true(pd_is_root(id, pd, ignore.groups = TRUE)) id <- min(pd[pd$token =="'{'", 'parent']) expect_equal(get_family_pd(id, pd)[3,'text'], "# Another Grouping") ids <- pd[pd$token =="'{'", 'parent'] expect_equal(pd_is_root(ids, pd, ignore.groups = TRUE ), c(TRUE, FALSE, FALSE)) expect_equal(pd_is_root(ids, pd, ignore.groups = FALSE), c(TRUE, FALSE, FALSE)) pd <- get_parse_data(parse(text=" # a comment an_expression() ", keep.source=TRUE)) expect_false(pd_is_root(pd[1,'id'], pd)) }) #line 158 "R/root.R" test_that('roots', {#@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) bases <- pd[pd$parent==0, 'id'] groups <- parent(.find_text('{')) expect_equal(pd_all_root_ids(pd, TRUE), bases) roots <- pd_all_root_ids(pd, FALSE) expected <- parent(.find_text('<-')) expect_equal(roots, expected) expect_equal(getParseText(pd, roots), c('a <- 1','b <- 2', 'c <- 3', 'd <- 4', 'e <- 5')) pd <- get_parse_data(parse(text=" # a comment an_expression() ", keep.source=TRUE)) expect_equal( pd_all_root_ids(pd), -pd[1,'parent']) pd <- utils::getParseData(parse(text={" {# grouped code # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } } {#Second Group 1+2 } # Comment 3 4+5 "}, keep.source=TRUE)) expect_equal(pd_all_root_ids(pd), pd[pd$parent==0, 'id']) }) #line 220 "R/root.R" test_that('all_root_nodes', {#!@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) expect_equal(all_root_nodes(pd, TRUE)$id , c(7, 52, 63)) expect_equal(all_root_nodes(pd, TRUE)$line1, c(1, 2, 9)) expect_equal(all_root_nodes(pd, FALSE)$id , c(7, 19, 31, 47, 63)) expect_equal(all_root_nodes(pd, FALSE)$line1, c(1, 3, 5, 7, 9)) }) #line 258 "R/root.R" test_that('ascend_to_root', {#@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) root <- roots(pd) expect_equal(ascend_to_root(id=root, pd), root) expect_equal(ascend_to_root(id=1 , pd), root) expect_identical(ascend_to_root(id=0, pd), 0L) pd <- get_parse_data(parse(text={" #' hello world hw <- function(){ #! title print('hello world!') } #' comment after "}, keep.source=TRUE)) root <- roots(pd) expect_equal(ascend_to_root(.find_text("#' hello world"), pd), root) expect_equal(ascend_to_root(pd$id, pd=pd), c(rep(root, nrow(pd)-1), 0L)) pd <- get_parse_data(parse(text={" { #' hello world hw <- function(){ #! title print('hello world!') } #' comment after }"}, keep.source=TRUE)) expect_false( ascend_to_root(.find_text('hw'), pd) %in% roots(pd)) expect_true( ascend_to_root(.find_text('hw'), pd) %in% roots(pd, FALSE)) expect_true(is_root(next_sibling(.find_text("#' hello world")))) }) parsetools/tests/testthat/test-comments.R0000644000176200001440000001512313615100113020365 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `comments.R`') #line 48 "R/comments.R" test_that('classify_comment.character', {#@testing expect_equal(classify_comment.character("## normal comment "), "NORMAL_COMMENT") expect_equal(classify_comment.character("#' Roxygen comment "), "ROXYGEN_COMMENT") expect_equal(classify_comment.character("#! Documentation comment"), "DOC_COMMENT") expect_equal(classify_comment.character("#< Relative comment "), "RELATIVE_COMMENT") expect_equal(classify_comment.character("#^ Continuation comment "), "CONTINUATION_COMMENT") expect_equal(classify_comment.character("#@ Tag comment "), "TAG_COMMENT") expect_equal(classify_comment.character("1"), "") }) #line 64 "R/comments.R" test_that('classify_comment.data.frame', {#@testing x <- df <- utils::getParseData(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) pd <- classify_comment.data.frame(df) expect_is(pd, 'data.frame') expect_is(pd, 'parse-data') expect_equal( pd$token , c( "expr", "'{'" , "NORMAL_COMMENT", "ROXYGEN_COMMENT", "DOC_COMMENT" , "RELATIVE_COMMENT", "CONTINUATION_COMMENT", "TAG_COMMENT" , "'}'") ) }) #line 85 "R/comments.R" test_that('classify_comment', {#@testing df <- utils::getParseData(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) pd <- classify_comment(df) comments <- nodes(all_comment_ids(pd)) expect_is(comments, 'data.frame') expect_is(comments, 'parse-data') expect_equal( comments$token , c( "NORMAL_COMMENT", "ROXYGEN_COMMENT", "DOC_COMMENT" , "RELATIVE_COMMENT", "CONTINUATION_COMMENT", "TAG_COMMENT" ) ) }) #line 123 "R/comments.R" test_that('is_comment', {#!@testing pd <- get_parse_data(parse(text={" ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment Hello "}, keep.source=TRUE)) rtn <- is_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(T,T,T,T,T,T,F,F)) expect_equal( all_comment_ids(pd), (1:6)*3L) }) #line 162 "R/comments.R" test_that('is_relative_comment', {#@testing pd <- get_parse_data(parse(text={" ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment Hello "}, keep.source=TRUE)) expect_is(rtn <- pd_is_relative_comment(pd$id, pd=pd), 'logical') expect_equal(rtn, c(F,F,F,T,F,F,F,F)) }) #line 193 "R/comments.R" test_that('is_doc_comment', {#@testing pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) rtn <- is_doc_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(F,F,F,T,T,T,T,T,F)) pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) rtn <- is_doc_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(F,F,F,T,T,T,T,T,F)) }) #line 226 "R/comments.R" test_that('strip_doc_comment_leads.character', {#@testing expect_equal(strip_doc_comment_leads.character("# normal comment "), "# normal comment") expect_equal(strip_doc_comment_leads.character("#' Roxygen comment "), "Roxygen comment") expect_equal(strip_doc_comment_leads.character("#! Documentation comment"), "Documentation comment") expect_equal(strip_doc_comment_leads.character("#< Relative comment "), "Relative comment") expect_equal(strip_doc_comment_leads.character("#^ Continuation comment "), "Continuation comment") expect_equal(strip_doc_comment_leads.character("#@ Tag comment "), "Tag comment") }) #line 242 "R/comments.R" test_that('strip_doc_comment_leads.data.frame', {#@testing pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) comments <- nodes(all_comment_ids(pd), pd) pd2 <- strip_doc_comment_leads.data.frame(comments) expect_is(pd2, 'data.frame') expect_is(pd2, 'parse-data') expect_equal( pd2$text , c( "## normal comment", "Roxygen comment" , "Documentation comment", "Relative comment" , "Continuation comment", "Tag comment" ) ) }) #line 274 "R/comments.R" test_that('strip_doc_comment_leads', {#@testing expect_equal(strip_doc_comment_leads("# normal comment "), "# normal comment") expect_equal(strip_doc_comment_leads("#' Roxygen comment "), "Roxygen comment") expect_equal(strip_doc_comment_leads("#! Documentation comment"), "Documentation comment") expect_equal(strip_doc_comment_leads("#< Relative comment "), "Relative comment") expect_equal(strip_doc_comment_leads("#^ Continuation comment "), "Continuation comment") expect_equal(strip_doc_comment_leads("#@ Tag comment "), "Tag comment") pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) comments <- nodes(all_comment_ids(pd)) pd2 <- strip_doc_comment_leads(comments) expect_is(pd2, 'data.frame') expect_is(pd2, 'parse-data') expect_equal( pd2$text , c( "## normal comment", "Roxygen comment" , "Documentation comment", "Relative comment" , "Continuation comment", "Tag comment" ) ) }) parsetools/tests/testthat/test-internal.R0000644000176200001440000000565313374663312020404 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `internal.R`') #line 35 "R/internal.R" test_that('internal', {#@testing external_test <- function(id, pd){"do something"} test <- internal(external_test) expected <- function(id=pd$id, pd=get('pd', parent.frame()))external_test(id=id, pd=pd) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) external_test2 <- function(id, pd, .check=TRUE){"do something"} test2 <- internal(external_test2) expected2 <- function(id=pd$id, pd=get('pd', parent.frame()))external_test2(id=id, pd=pd, .check=FALSE) environment(expected2) <- asNamespace('parsetools') expect_identical(test2, expected2) external_test3 <- function(id, pd, N=1){"do something"} test3 <- internal(external_test3) expected3 <- function(id=pd$id, pd=get('pd', parent.frame()), ...)external_test3(id=id, pd=pd, ...) environment(expected3) <- asNamespace('parsetools') expect_identical(test3, expected3) external_test4 <- function(id, pd, N=1, .check=TRUE){"do something"} test4 <- internal(external_test4) expected4 <- function(id=pd$id, pd=get('pd', parent.frame()), ...)external_test4(id=id, pd=pd, ..., .check=FALSE) environment(expected4) <- asNamespace('parsetools') expect_identical(test4, expected4) }) #line 86 "R/internal.R" test_that('make_get_all', {#@test pd_is_test <- function(id, pd, n=Inf, .check=TRUE){"do something"} test_all <- make_get_all(pd_is_test) expected <- function(pd=get('pd', parent.frame()),...)pd[pd_is_test(id=pd$id, pd=pd, ..., .check=FALSE), "id"] expect_equal(test_all, expected) }) #line 117 "R/internal.R" test_that('external', {#@testing internal_test <- function(id=pd$id, pd=get('pd', parent.frame())){"do something"} test <- external(internal_test) expected <- function(id, pd)internal_test(id=id, pd=pd) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), .check=FALSE){"do something"} test <- external(internal_test) expected <- function(id, pd)internal_test(id=id, pd=pd, .check=TRUE) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), N=1){"do something"} test <- external(internal_test) expected <- function(id, pd, ...)internal_test(id=id, pd=pd, ...) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), N=1, .check=FALSE){"do something"} test <- external(internal_test) expected <- function(id, pd, ...)internal_test(id=id, pd=pd, ..., .check=TRUE) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) }) parsetools/tests/testthat/test-get_parse_data.R0000644000176200001440000002245413615100113021507 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `get_parse_data.R`') #line 45 "R/get_parse_data.R" test_that('get_srcfile', {#@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) }) #line 101 "R/get_parse_data.R" test_that('fix_eq_assign', {#! @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)) }) #line 181 "R/get_parse_data.R" test_that('get_parse_data.srcfile', {#@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) }) #line 245 "R/get_parse_data.R" test_that('get_parse_data.srcref', {#@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) }) #line 287 "R/get_parse_data.R" test_that('get_parse_data.function basic', {#@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")) }) #line 303 "R/get_parse_data.R" test_that('get_parse_data.function grouped', {#@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")) }) #line 319 "R/get_parse_data.R" test_that('get_parse_data.function nested', {#@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")) }) #line 339 "R/get_parse_data.R" test_that('get_parse_data.function S4 Generic', {#@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') }) #line 357 "R/get_parse_data.R" test_that('get_parse_data.function', {#@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") }) #line 386 "R/get_parse_data.R" test_that('get_parse_data.default', {#@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\\.") }) #line 401 "R/get_parse_data.R" test_that('`subset.parse-data`', {#@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) }) #line 429 "R/get_parse_data.R" test_that('`[.parse-data`', {#@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')) }) #line 445 "R/get_parse_data.R" test_that('`-.parse-data`', {#@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)) }) #line 503 "R/get_parse_data.R" test_that('as.data.frame.parseData', {#@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)) }) #line 539 "R/get_parse_data.R" test_that('valid_parse_data', {#@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") }) #line 563 "R/get_parse_data.R" test_that('as_parse_data', {#@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") }) parsetools/tests/testthat/test-tags.R0000644000176200001440000001126013615100114017475 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `tags.R`') #line 81 "R/tags.R" test_that('pd_has_tag', {#!@testing # Note that testthat:::test_code will strip comments from code # this requires a parse statement. pd <- get_parse_data(parse(text='fun <- function(object){ #! function with only comment lines #! @tag TRUE #! @@tag FALSE #! @notag{@tag}@ FALSE # @tag TRUE, even though a regular comment object @tag NULL }', keep.source=TRUE)) tag <- 'tag' id <- pd$id expect_equal(sum(pd_has_tag(id, pd, tag)), 2) }) #line 102 "R/tags.R" test_that('has_tag', {#@testing pd <- parsetools::get_parse_data(parse(text={" if(FALSE){#@block block content #' @first first content #' @second second content #' not part of second content. #' @last } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 4L) }) #line 126 "R/tags.R" test_that('clean_tag_comments', {#!@testing expect_equal( clean_tag_comments("#@testing", "testing") , "#! @testing" ) }) #line 151 "R/tags.R" test_that('strip_tag', {#! @testthat expect_equal( strip_tag("@tag should be removed", 'tag') , "should be removed") expect_equal( strip_tag("@nomd{@tag}@ should not be removed", 'tag') , "@nomd{@tag}@ should not be removed") expect_equal( strip_tag("@@tag should not be removed.", 'tag') , "@@tag should not be removed.") }) #line 178 "R/tags.R" test_that('pd_get_tagged_comment_ids', {#!@testing pd <- parsetools::get_parse_data(parse(text={" fun <- function(object){ #! function with only comment lines #! @tag TRUE #! @@tag FALSE #! @notag{@tag}@ FALSE # @tag TRUE, even though a regular comment object @tag NULL } "}, keep.source=TRUE)) tag <- 'tag' id <- pd$id expect_equal(pd_get_tagged_comment_ids(pd, tag, TRUE ), 15L ) expect_equal(pd_get_tagged_comment_ids(pd, tag, FALSE), c(15L, 21L)) }) #line 222 "R/tags.R" test_that('pd_get_comment_tag_content', {#@testing pd <- parsetools::get_parse_data(parse(text={" if(FALSE){#@block block content #' @first first content #' @second second content #' not part of second content. #' @last } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 4L) block.id <- pd_get_tagged_comment_ids(pd, 'block') expect_identical( pd_get_comment_tag_content(block.id, pd, 'block') , "block content") expect_error( pd_get_comment_tag_content(block.id, pd, 'invalid')) first.id <- pd_get_tagged_comment_ids(pd, 'first') expect_identical( pd_get_comment_tag_content(first.id, pd, 'first') , "first content") second.id <- pd_get_tagged_comment_ids(pd, 'second') expect_identical( pd_get_comment_tag_content(second.id, pd, 'second') , "second content") expect_identical( pd_get_comment_tag_content(second.id, pd, 'second', all.contiguous = TRUE) ,c( "second content", "not part of second content.")) last.id <- pd_get_tagged_comment_ids(pd, 'last') expect_identical( pd_get_comment_tag_content(last.id, pd, 'last') , "") }) #line 254 "R/tags.R" test_that('edge cases', {#@testing edge cases pd <- parsetools::get_parse_data(parse(text={" f <- function(){ #' @testtag comment lines #' That aren't contiguous. #' because they are separated by a blank line. #' @testtag2 These are contiguous #' #' Because the line separating them is #' a documentation comment itself. print('hello world') #' and testtag2 ends due to an expression. } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 2L) id <- pd_get_tagged_comment_ids(pd, 'testtag') expect_identical( pd_get_comment_tag_content(id, pd, 'testtag', TRUE) , "comment lines") id <- pd_get_tagged_comment_ids(pd, 'testtag2') expect_identical( pd_get_comment_tag_content(id, pd, 'testtag2', TRUE) , c( "These are contiguous" , "" , "Because the line separating them is" , "a documentation comment itself." )) }) parsetools/tests/testthat/test-grouping.R0000644000176200001440000000613413615100113020374 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `grouping.R`') #line 50 "R/grouping.R" test_that('is_grouping', {#@testing pd <- get_parse_data(parse(text='{ this(is+a-grouping) }', keep.source=TRUE)) id <- pd[match("'{'", pd$token), 'id'] gid <- parent(id) expect_true (pd_is_grouping(gid, pd)) expect_false(pd_is_grouping( 1L, pd)) expect_is(pd_is_grouping(pd$id, pd=pd), 'logical') expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 1) expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 1L) pd <- get_parse_data(parse(text=' {# first Group {# nested group "expression in double nested group" } } ', keep.source=TRUE)) expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 2) }) #line 79 "R/grouping.R" test_that('all_grouping_ids', {#@testing pd <- get_parse_data(parse(text='{ this(is+a-grouping) }', keep.source=TRUE)) expect_is(all_grouping_ids(pd), 'integer') expect_equal(length(all_grouping_ids(pd)), 1) expect_equal(all_grouping_ids(pd), pd[match("'{'", pd$token), 'parent']) }) #line 116 "R/grouping.R" test_that('fix_grouping_comment_association', {#@testing pd <- get_parse_data(parse(text={" {# grouped code # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } } {# Second Group 1+2 } # Comment 3 4+5 "}, keep.source=TRUE)) ids <- all_grouping_ids(pd) fixed <- fix_grouping_comment_association(ids, pd) expect_identical( -parent(.find_text("#' Documenation before", fixed), fixed) , parent(.find_text('<-')) ) expect_identical(fixed[-6], pd[-6]) text(all_comment_ids(fixed), fixed) x <- pd_get_ancestor_ids(.find_text('print', fixed), fixed) inside.parent <- max(x[is_in_function(x, fixed) & ! is_function(x)]) expect_equal( abs(parent(all_comment_ids(fixed), fixed)) , c( rep(ascend_to_root(.find_text('hw', fixed), fixed), 3) , inside.parent , parent(.find_text('+')) ) ) }) #line 157 "R/grouping.R" test_that('fix_grouping_comment_association Special case', {#@test fix_grouping_comment_association Special case pd <- get_parse_data(parse(text={" {#' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } }"}, keep.source=TRUE)) fixed <- fix_grouping_comment_association(roots(pd), pd) expect_equal(nrow(pd), nrow(fixed)) expect_identical(pd$id, fixed$id) cid <- .find_text("#' Documenation before") expect_true( parent(cid, fixed) != parent(cid, pd)) expect_true(is_assignment(abs(parent(cid, fixed)), fixed)) expect_true(!any(is_comment(children(roots(fixed), fixed), fixed))) }) parsetools/tests/testthat/test-siblings.R0000644000176200001440000000270713422625462020375 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `siblings.R`') #line 64 "R/siblings.R" test_that('next_sibling', {#@testing pd <- get_parse_data(parse(text='a+b', keep.source = TRUE)) id <- parent(.find_text('a')) expect_equal( pd_get_next_sibling_id(id,pd) , parent(.find_text('b')) ) expect_identical( pd_get_next_sibling_id(.find_text('a', pd), pd), NA_integer_) expect_identical( pd_get_next_sibling_id(.find_text('+', pd), pd) , parent(.find_text('a', pd)) ) expect_length(pd_get_next_sibling_id(pd$id, pd), nrow(pd)) expect_error(pd_get_next_sibling_id(1e9L, pd)) expect_error(pd_get_next_sibling_id(id, id)) }) #line 92 "R/siblings.R" test_that('prev_sibling', {#@testing pd <- get_parse_data(parse(text='a+b', keep.source = TRUE)) id <- parent(.find_text('b')) expect_equal( pd_get_prev_sibling_id(id,pd) , parent(.find_text('a')) ) expect_identical( pd_get_prev_sibling_id(.find_text('b', pd), pd), NA_integer_) expect_identical( pd_get_prev_sibling_id(parent(.find_text('a', pd)), pd) , .find_text('+', pd)) expect_length(pd_get_prev_sibling_id(pd$id, pd), nrow(pd)) expect_error(pd_get_prev_sibling_id(1e9L, pd)) expect_error(pd_get_prev_sibling_id(id, id)) }) parsetools/tests/testthat/test-reconstitute.R0000644000176200001440000000370013401560544021301 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `reconstitute.R`') #line 102 "R/reconstitute.R" test_that('reconstitute', {#@testing pd <- get_parse_data(parse(text='rnorm(10L, mean=0, sd=1)', keep.source=TRUE)) id <- roots(pd) x <- substitute(rnorm(10L, mean=0, sd=1)) expect_identical( reconstitute(id), x) pd <- get_parse_data(p <- parse(text="'pd'", keep.source=TRUE)) expect_identical( reconstitute(roots(pd)) , substitute('pd') ) pd <- get_parse_data(p <- parse(text='get(\'pd\', parent.frame())', keep.source=TRUE)) expect_identical( reconstitute(roots(pd)) , substitute(get('pd', parent.frame()), emptyenv()) ) pd <- get_parse_data(parse(text={' function(id, pd=get(\'pd\', parent.frame())){ fb <- firstborn(id) reconstitute(fb) } '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- reconstitute(id, pd) expect_is(reconstituted, 'call') expected <- quote(function(id, pd=get('pd', parent.frame())){ fb <- firstborn(id) reconstitute(fb) }) expect_equal(reconstituted, expected) }) #line 136 "R/reconstitute.R" test_that('reconstitute if statements}', {#@test reconstitute if statements} pd <- get_parse_data(parse(text={' if (TRUE) "YES" else "NO" '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- pd_reconstitute(id, pd) expect_is(reconstituted, 'if') expected <- quote(if (TRUE) "YES" else "NO") expect_equal(reconstituted, expected) pd <- get_parse_data(parse(text={' if (TRUE) "YES" '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- pd_reconstitute(id, pd) expect_is(reconstituted, 'if') expected <- quote(if (TRUE) "YES") expect_equal(reconstituted, expected) }) parsetools/tests/testthat/test-firstborn.R0000644000176200001440000000120713374663312020567 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `firstborn.R`') #line 53 "R/firstborn.R" test_that('firstborn', {#@testing pd <- get_parse_data(parse(text='a+b', keep.source = TRUE)) fb <- pd_get_firstborn(roots(pd), pd) expect_identical(token(fb), "'+'") expect_true(pd_is_firstborn(fb, pd)) expect_true(pd_is_firstborn(roots(pd), pd)) expect_false(pd_is_firstborn(next_sibling(fb), pd)) expect_true(fb %in% siblings(fb,pd)) expect_length(siblings(fb,pd), 3L) expect_equal(sum(pd_is_firstborn(siblings(fb,pd), pd)), 1L) }) parsetools/tests/testthat/test-accessors.R0000644000176200001440000001044013615104577020544 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `accessors.R`') #line 41 "R/accessors.R" test_that('token', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) expect_equal(token(), pd$token) ids <- pd$id[match(c('rnorm', 'x', '<-'), pd$text)] expect_equal( token(ids, pd) , c("SYMBOL_FUNCTION_CALL", "SYMBOL", "LEFT_ASSIGN")) }) #line 58 "R/accessors.R" test_that('text', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) text <- c('rnorm', 'x', '<-') ids <- pd$id[match(c('rnorm', 'x', '<-'), pd$text)] expect_equal(text(pd$id, pd), pd$text) expect_equal(text(ids), text) expect_equal(text(ids, pd), text) }) #line 76 "R/accessors.R" test_that('nodes', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) expect_equal(nodes(pd$id, pd), pd) expect_equal(nodes(pd$id), pd) expect_equal(nodes(c(45,3, 58), pd), pd[c('45', '3', '58'), ]) }) #line 117 "R/accessors.R" test_that('filename', {#@test pd <- get_parse_data(parse(text="1+1")) expect_identical(filename(pd), "") attr(pd, 'srcfile') <- NULL expect_identical(filename(pd), "") }) #line 144 "R/accessors.R" test_that('is_first_on_line', {#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_true (is_first_on_line(1)) expect_false(is_first_on_line(2)) pd <- get_parse_data(parse(text={ "function(x, y){ x+ y+ 1 } "}, keep.source=TRUE)) }) #line 169 "R/accessors.R" test_that('is_last_on_line', {#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_false(is_last_on_line(1, pd)) expect_true(is_last_on_line(4, pd)) expect_false(is_last_on_line(6, pd)) }) #line 184 "R/accessors.R" test_that('spans_multiple_lines', {#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_true(spans_multiple_lines(1, pd)) expect_false(spans_multiple_lines(4, pd)) expect_true(spans_multiple_lines(pd_all_root_ids(pd), pd)) }) #line 198 "R/accessors.R" test_that('terminal_ids_on_line', {#@testing pd <- get_parse_data(parse(text=" { {1 + 3} {2 + sin(pi)} } ", keep.source=TRUE)) expect_equal(terminal_ids_on_line(1), 1) expect_equal(text(terminal_ids_on_line(2)), c('{', '1', '+', '3', '}')) pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_equal(text(terminal_ids_on_line(1, pd)), "'\n\n'") expect_equal(terminal_ids_on_line(2, pd), 1) expect_equal(terminal_ids_on_line(4, pd), integer(0)) }) #line 227 "R/accessors.R" test_that('ids_ending_on_line', {#@testing pd <- get_parse_data(parse(text={"((1+ 2)+ 3)+ 4"}, keep.source=TRUE)) expect_identical(ids_starting_on_line(1), head(pd$id, 10)) expect_identical(ids_starting_on_line(4), tail(pd$id, 2)) expect_identical(ids_ending_on_line(1), 1:5) expect_identical(ids_ending_on_line(4), c(26L, 23L, 24L)) }) #line 251 "R/accessors.R" test_that('prev_terminal', {#@testing pd <- get_parse_data(parse(text=" rnorm( 10, 0, 3)", keep.source=TRUE)) ids <- pd$id[match(c('10', '(', 'rnorm'), pd$text)] id <- ids[[1]] expect_equal( prev_terminal(ids[[1]], pd), ids[[2]]) expect_equal( prev_terminal(ids[[2]], pd), ids[[3]]) expect_equal( prev_terminal(ids[[3]], pd), NA_integer_) expect_equal( prev_terminal(ids, pd=pd) , c(utils::tail(ids, -1), NA_integer_) ) }) #line 275 "R/accessors.R" test_that('expr_text', {#@testing pd <- get_parse_data(parse(text=" signature(x='hello', y='world') ", keep.source=TRUE)) ids <- c( parent(.find_text("'hello'")) , parent(.find_text("'world'")) ) expect_identical(expr_text(ids, pd), c("hello", "world")) expect_error( expr_text(pd_all_root_ids(pd)) , ":2:9: a string constant is expected." ) }) parsetools/tests/testthat/test-pd_function.R0000644000176200001440000001041113402020702021042 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_function.R`') #line 57 "R/pd_function.R" test_that('pd_is_function', {#! @testthat pd_is_function pd <- get_parse_data(parse(text="function(){}", keep.source=TRUE)) expect_true(pd_is_function(roots(pd), pd)) pd <- get_parse_data(parse(text="fun <- function(){}", keep.source=TRUE)) expect_false(pd_is_function(roots(pd), pd)) expect_length(all_function_ids(pd), 1L) }) #line 80 "R/pd_function.R" test_that('is_in_function', {#@testing ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) id <- .find_text('"Congratulations!"') expect_true(pd_is_in_function(id, pd)) id <- .find_text('"myClass"') expect_identical(is_in_function(id), c(FALSE, FALSE)) }) #line 106 "R/pd_function.R" test_that('function_body', {#@testing pd <- get_parse_data(parse(text="hello_world <- function(){ print('hello world') } ", keep.source=TRUE)) id <- all_function_ids(pd) expect_equal(pd_get_function_body_id(id, pd), parent(.find_text('{'))) pd <- get_parse_data(parse(text='function(l,r)paste(l,r)', keep.source=TRUE)) expect_identical( pd_get_function_body_id(all_function_ids(pd), pd=pd) , parent(parent(.find_text('paste')), pd) ) }) #line 120 "R/pd_function.R" test_that('function_body vectorizing', {#@testing function_body vectorizing pd <- get_parse_data(parse(text=" hello_world <- function(){ print('hello world') } goodby_earth <- function(){ print('goodby earth') } ", keep.source=TRUE)) id <- all_function_ids(pd) expect_equal(pd_get_function_body_id(id, pd), parent(.find_text('{'))) }) #line 147 "R/pd_function.R" test_that('function_args', {#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_function_ids(pd) expect_identical( text(pd_get_function_arg_ids(id, pd), pd=pd) , c('(', 'pd', '#< parse data', ',' , 'id', '=', '', '#< id number', ')' ) ) }) #line 175 "R/pd_function.R" test_that('function_arg_variables', {#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- assign_value(all_assignment_ids(pd)) expected <- pd[pd$parent==id & pd$text %in% c('pd', 'id'), 'id'] expect_identical(pd_get_function_arg_variable_ids(id, pd), expected) expect_error(pd_get_function_arg_variable_ids(roots(pd), pd)) }) #line 191 "R/pd_function.R" test_that('pd_get_function_arg_variable_text', {#@testing pd <- get_parse_data(parse(text=' function( a, b = 1){ cat("hello world") }', keep.source=TRUE)) id <- roots(pd) expect_identical( pd_get_function_arg_variable_text(id, pd) , c("a", "b") ) }) #line 221 "R/pd_function.R" test_that('is_function_arg', {#@testing pd <- get_parse_data(parse(text=' function( a, b = 1){ cat("hello world") }', keep.source=TRUE)) id <- .find_text('a') expect_true(pd_is_function_arg(id, pd)) expect_false(pd_is_function_arg(.find_text('"hello world"'), pd)) expect_length(is_function_arg(pd$id, pd), nrow(pd)) expect_equal(sum(is_function_arg(pd$id, pd)), 4) }) #line 252 "R/pd_function.R" test_that('function_arg_associated_comments', {#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data #< continuation comment , id = pd_all_root_ids(pd) ){}', keep.source=TRUE)) function.id <- assign_value(all_assignment_ids(pd), pd) arg.ids <- function_arg_variables(function.id, pd) id <- arg.ids[[1]] expect_identical(text(pd_get_function_arg_associated_comment_ids(id, pd), pd=pd) , c('#< parse data', '#< continuation comment')) expect_length(pd_get_function_arg_associated_comment_ids(arg.ids[[2]], pd), 0) }) parsetools/tests/testthat/test-pd_call.R0000644000176200001440000000522613615100114020142 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_call.R`') #line 65 "R/pd_call.R" test_that('is_call', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_true (pd_is_call(ids[[3]], pd)) expect_false(pd_is_call(ids[[1]], pd)) expect_equal(pd_is_call(ids, pd), c(F, F, T)) }) #line 77 "R/pd_call.R" test_that('non-symbol calls', {#@test non-symbol calls text <- 'function_array[[1]](1)' text <- 'getAnywhere(rnorm)[1](1)' pd <- get_parse_data(parse(text=text, keep.source = TRUE)) id <- roots(pd) expect_true(pd_is_call(id, pd)) }) #line 102 "R/pd_call.R" test_that('is_symbol_call', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_true (pd_is_symbol_call(id, pd)) expect_false(pd_is_symbol_call(ids[[1]], pd)) expect_equal(pd_is_symbol_call(ids, pd), c(F, F, T)) expect_false(pd_is_symbol_call(ids[[1]], pd)) }) #line 116 "R/pd_call.R" test_that('non-symbol call', {#@test non-symbol call pd <- get_parse_data(parse(text={" (function()cat('hello world!'))() "}, keep.source=TRUE)) id <- roots(pd) expect_true(pd_is_call(id, pd)) expect_false(pd_is_symbol_call(id, pd)) }) #line 138 "R/pd_call.R" test_that('call_symbol', {#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_equal( pd_get_call_symbol_id(id, pd) , .find_text('plot')) }) #line 192 "R/pd_call.R" test_that('call_args', {#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) test.object <- pd_get_call_arg_ids(roots(pd), pd=pd) expect_is(test.object, 'integer') expect_equal(names(test.object), c('', 'mean', 'sd')) expect_identical( test.object , c( 5L , mean=parent(.find_text('0')) , sd =parent(.find_text('1'))) ) pd <- get_parse_data(parse(text='alist(x, y=z, ...=)', keep.source=TRUE)) expect_identical( call_args(all_call_ids(pd), pd=pd) , c( parent(.find_text('x')) , y = parent(.find_text('z')) , '...'=NA_integer_)) }) parsetools/tests/testthat/test-errors.R0000644000176200001440000000162013373622441020067 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `errors.R`') #line 13 "R/errors.R" test_that('errors', {#@testing errors pd <- get_parse_data(parse(text=' classDef <- setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) )', keep.source=TRUE)) id <- pd[pd$text == "#< the x field", 'id'] expect_error(line_error(id, 'testing', pd=pd) , ":3: testing") expect_error(line_error_if(TRUE, id, 'testing', pd=pd) , ":3: testing") expect_error( col_error(id, 'testing col error', pd=pd) , ":3:35: testing col error") expect_silent(line_error_if(FALSE, id, 'testing', pd=pd)) expect_null(line_error_if(FALSE, id, 'testing', pd=pd)) }) parsetools/tests/testthat/test-checks.R0000644000176200001440000000265513334330011020006 0ustar liggesusers#! This file was automatically produced by the documentation package. #! Changes will be overwritten. context('tests extracted from file `checks.R`') #line 43 "/rdtf/parsetools/R/checks.R" test_that('._check_id', {#!@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) expect_error(._check_id(pd) , "id must be an object that can be coerced to an integer", info="Passing parse-data") expect_error(._check_id(iris), "id must be an object that can be coerced to an integer", info="data.frame but not parse-data") expect_identical(._check_id(1) , 1L , info="convert numeric to integer") expect_identical(._check_id(1.1), 1L , info="convert numeric to integer") expect_error(._check_id(TRUE) , info="passing logical that cannot be converted.") expect_error( ._check_id(1000, pd) , 'id\\(1000\\) is not present in given parse-data.' , info="passing logical that cannot be converted." ) }) #line 64 "/rdtf/parsetools/R/checks.R" test_that('._check_parse_data', {#!@testing df <- getParseData(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) pd <- ._check_parse_data(df) expect_is(pd, "parse-data") expect_error(._check_parse_data(NULL), "Cannot convert to parse-data.", info="passing NULL") expect_error(._check_parse_data(iris), "names of data do not conform", info="passing non-conforming data.frame") }) parsetools/tests/testthat/test-pd_assign.R0000644000176200001440000000533413615112263020523 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_assign.R`') #line 41 "C:/rdtf/parsetools/R/pd_assign.R" test_that('is_assignment', {#@testing pd1 <- get_parse_data(parse(text="x <- 1", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd1), pd=pd1)) pd2 <- get_parse_data(parse(text="x <<- 1", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd2), pd=pd2)) pd3 <- get_parse_data(parse(roots(pd), text="1 -> x", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd3), pd=pd3)) pd4 <- get_parse_data(parse(text="1 ->> x", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd4), pd=pd4)) pd5 <- get_parse_data(parse(text="x = 1", keep.source=TRUE)) expect_equal(sum(pd_is_assignment(pd5$id, pd5)), 1) if(R.version$major < 4) { expect_true(pd_is_assignment(roots(pd5), pd=pd5)) } else { expect_false(pd_is_assignment(roots(pd5), pd=pd5)) expect_true(pd_is_assignment(firstborn(roots(pd5), pd5), pd5), pd5) } }) #line 81 "C:/rdtf/parsetools/R/pd_assign.R" test_that('assign_value', {#!@testing pd <- get_parse_data(parse(text="x<-1", keep.source=TRUE)) expect_equal(pd_get_assign_value_id(all_assignment_ids(pd), pd=pd), 5L) pd <- get_parse_data(parse(text="x=1", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="x<<-1", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="1->x", keep.source=TRUE)) expect_equal(pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="1->>x", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1'))) }) #line 123 "C:/rdtf/parsetools/R/pd_assign.R" test_that('assign_variable', {#!@testthat pd <- get_parse_data(parse(text="hello_world <- function(){ print('hello world') } ", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd), pd=pd)) expect_equal( pd_get_assign_variable_id(roots(pd), pd=pd) , parent(.find_text("hello_world"))) }) #line 133 "C:/rdtf/parsetools/R/pd_assign.R" test_that('right_assign', {#@test right_assign pd <- get_parse_data(parse(text="'hello_world' -> hw", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd), pd)) expect_equal( pd_get_assign_variable_id(roots(pd), pd=pd) , parent(.find_text("hw"))) }) parsetools/tests/testthat/test-testing_blocks.R0000644000176200001440000001641713401610222021561 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `testing_blocks.R`') #line 103 "/rdtf/parsetools/R/testing_blocks.R" test_that('extract_test_block', {#!@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 :2:5" , info = "cannot find name for block" ) expect_equal( extract_test_block(iff.ids[[2L]], pd) , structure(c( '#line 9 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , 'test_that(\'hello_world\', {#!@testthat' , ' expect_output(hello_world(), "hello world")' , ' })' , '#line 14 ""' , '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 ""' , 'test_that(\'as(class1, "class2")\', {#!@testing' , ' #testing setAs' , ' })' ) , name = c("as(class1, \"class2\")") ) , info = "setAs") }) #line 230 "/rdtf/parsetools/R/testing_blocks.R" test_that('Extraction with block tag.', {#@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 \"\"" , "test_that('An info string', {#@testing An info string" , " expect_true(T)" , " })" ) , name = "An info string") , info = "using text string") }) #line 258 "/rdtf/parsetools/R/testing_blocks.R" test_that('extract_test_blocks_parse_data', {#@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)) }) #line 279 "/rdtf/parsetools/R/testing_blocks.R" test_that('extract_test_blocks', {#! @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.") }) parsetools/tests/testthat/test-zzz.R0000644000176200001440000000453113373624302017412 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `zzz.R`') #line 7 "R/zzz.R" test_that('export compliance', {#! @test export compliance grep('^all_', getNamespaceExports('parsetools'), value=TRUE) %>% grep('_ids', ., value=TRUE, invert=TRUE) grep('^get_', getNamespaceExports('parsetools'), value=TRUE) %>% grep("ids$",., value=TRUE, invert = TRUE) %>% grep("^get_parse_data", ., value=TRUE, invert=TRUE) grep('^is_', getNamespaceExports('parsetools'), value=TRUE) %>% grep('\\.(data\\.frame|parse-data|character)$', ., invert=TRUE, value=TRUE) names.pd_is_ <- grep('pd_is_', getNamespaceExports('parsetools'), value=TRUE) for(i in seq_along(names.pd_is_)){ name <- names.pd_is_[[i]] f <- get(name, asNamespace('parsetools')) args <- formals(f) id.present <- match('id' , names(args)) pd.present <- match('pd' , names(args)) check.present <- match('.check', names(args)) if (!is.na(id.present)){ expect_true( formal_arg_is_missing(args$id) , paste0( "argument `id` for function '", names.pd_is_[[i]], "' " , " should not have a default." ) ) expect_equal(id.present, 1L) } if (!is.na(pd.present)){ expect_true( formal_arg_is_missing(args$pd) , paste0( "argument `pd` for function '", names.pd_is_[[i]], "' " , " should not have a default." ) ) expect_equal(pd.present, if (id.present) 2L else 1L) } if (!is.na(check.present)) { expect_true( identical(args$.check, TRUE) , paste0( "argument `.check` for function '", names.pd_is_[[i]], "' " , " should default to `TRUE`." ) ) if (pd.present) expect_true(pd.present < check.present) } else if (!is.na(pd.present)) fail(paste0('if argument `pd` is present argument `.check` is required to be present' , " for exported function '", names.pd_is_[[i]], "'.")) } }) parsetools/tests/testthat/test-children.R0000644000176200001440000000712313615100112020330 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `children.R`') #line 100 "R/children.R" test_that('children', {#! @test pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) id <- pd[pd$parent==0, 'id'] kids <- pd[pd$parent==id, 'id'] expect_equal( pd_get_children_ids(id, pd, 1, include.self = FALSE) , kids , info="for default values" ) expect_equal( pd_get_children_ids(id, pd, 1, include.self=TRUE) , c(id,kids) , info='include.self=TRUE' ) grandkids <- pd[pd$parent %in% kids, 'id'] expect_equal( pd_get_children_ids( id, pd, 2, include.self=FALSE , aggregate = FALSE ) , grandkids , info='ngenerations=2, include.self=FALSE, aggregate=FALSE' ) expect_equal( sort(pd_get_children_ids( id, pd , ngenerations=2 , include.self=FALSE , aggregate = TRUE )) , sort(c(kids, grandkids)) , info='ngenerations=2, include.self=FALSE, aggregate=TRUE' ) expect_equal( sort(pd_get_children_ids( id, pd , ngenerations=2 , include.self=TRUE , aggregate = TRUE )) , sort(c(id, kids, grandkids)) , info='ngenerations=2, include.self=TRUE, aggregate=TRUE' ) expect_error( pd_get_children_ids(.Machine$integer.max, pd) , "id\\([0-9]+\\) is not present in given parse-data." ) expect_true( all(pd$id %in% pd_get_children_ids(0, pd, Inf))) }) #line 160 "R/children.R" test_that('get_children_pd', {#!@test 'rnorm(10, mean=0, sd=1)' -> text pd <- get_parse_data(parse(text=text, keep.source=TRUE)) id <- pd[match('rnorm', pd$text), 'parent'] expect_identical( get_children_pd(id, pd), utils::head(pd, 1), info='defaults') expect_identical( get_children_pd(id, pd, include.self=TRUE), utils::head(pd, 2), info='include.self=TRUE') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=1, include.self=FALSE) , pd[pd$parent==parent(id),] , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=1, include.self=TRUE) , pd[pd$parent==parent(id) | pd$id==parent(id),] , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=2, include.self=TRUE) , pd , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=2, include.self=FALSE, aggregate=FALSE) , pd[pd$parent != parent(id) & pd$parent != 0, ] , info='defaults') expect_error(get_children_pd(id=pd$id, pd=pd)) }) #line 194 "R/children.R" test_that('n_children', {#@testing ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) expect_equal(n_children(roots(pd)), c(3, 3, 8)) }) parsetools/tests/testthat/test-pd_comments.R0000644000176200001440000000507713374663313021101 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_comments.R`') #line 46 "R/pd_comments.R" test_that('function relative comments', {#@test function relative comments pd <- get_parse_data(parse(text='function( pd #< parse data #< continuation comment , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) value <- pd_get_relative_comment_associated_ids(id, pd) expect_identical(value[[1]], value[[2]]) expect_identical(text(value, pd=pd), c('pd', 'pd', 'id')) # while one argument documented and another not should be discouraged, # it is allowed. pd <- get_parse_data(parse(text='function( id, pd = get("pd", parent.frame()) #< parse data ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) expect_identical(text(pd_get_relative_comment_associated_ids(id, pd), pd=pd), 'pd') pd <- get_parse_data(parse(text='function( id, #< traditional comma placement. pd = get("pd", parent.frame()) #< parse data ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) value <- pd_get_relative_comment_associated_ids(id, pd) expected <- pd[ token(pd$id, pd=pd) == "SYMBOL_FORMALS" & text(pd$id, pd=pd) %in% c("pd", "id") , 'id'] expect_identical(value, expected) }) #line 76 "R/pd_comments.R" test_that('class members', {#@test class members pd <- get_parse_data(parse(text=' classDef <- setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) )', keep.source=TRUE)) ids <- all_relative_comment_ids(pd) id <- ids[[1]] expect_true(pd_is_in_class_definition(id,pd)) expect_identical( pd_is_in_class_definition(ids,pd), c(TRUE, TRUE)) expect_false(pd_is_in_class_definition(.find_text('classDef',pd), pd)) }) #line 92 "R/pd_comments.R" test_that('no possible relative.', {#@test no possible relative. pd <- get_parse_data(parse(text=' #< not a valid relative comment. function( #< also not valid pd #< continuation comment , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd)[[1]] expect_true(is.na(pd_get_relative_comment_associated_ids(id, pd))) id <- all_relative_comment_ids(pd)[[2]] expect_true(is.na(pd_get_relative_comment_associated_ids(id, pd))) }) parsetools/tests/testthat/test-iff_blocks.R0000644000176200001440000002403713402012243020645 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `iff_blocks.R`') #line 85 "/rdtf/parsetools/R/iff_blocks.R" test_that('is_iff', {#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# not an if(F)block } if(FALSE) expect_true(TRUE) #< IFF but not a block "}, keep.source=TRUE)) expect_true (pd_is_iff(roots(pd)[[1]], pd)) expect_true (pd_is_iff(roots(pd)[[2]], pd)) expect_false(pd_is_iff(roots(pd)[[2]], pd, FALSE)) expect_false(pd_is_iff(roots(pd)[[3]], pd)) expect_true (pd_is_iff(roots(pd)[[4]], pd)) expect_equal(pd_is_iff(roots(pd), pd), c(TRUE, TRUE, FALSE, TRUE)) expect_equal( is_iff(pd=pd), c(TRUE, TRUE, FALSE, TRUE)) }) #line 137 "/rdtf/parsetools/R/iff_blocks.R" test_that('is_iff_block', {#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# not an if(F)block } if(FALSE) expect_true(TRUE) #< IFF but not a block "}, keep.source=TRUE)) expect_true (pd_is_iff_block(roots(pd)[[1]], pd)) expect_true (pd_is_iff_block(roots(pd)[[2]], pd)) expect_false(pd_is_iff_block(roots(pd)[[2]], pd, FALSE)) expect_false(pd_is_iff_block(roots(pd)[[3]], pd)) expect_false(pd_is_iff_block(roots(pd)[[4]], pd)) expect_equal(pd_is_iff_block(roots(pd), pd), c(TRUE, TRUE, FALSE, FALSE)) expect_equal(pd_is_iff_block(roots(pd), pd, FALSE), c(TRUE, FALSE, FALSE, FALSE)) expect_equal( is_iff_block(pd=pd), c(TRUE, TRUE, FALSE, FALSE)) }) #line 179 "/rdtf/parsetools/R/iff_blocks.R" test_that('all_iff_block_ids', {#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# grouping block if(F){# iff nested in group } } hw <- function(){ if(F){# nested in a function } print('hello world') } "}, keep.source=TRUE)) iff.ids <- all_iff_block_ids(pd, root.only=TRUE, ignore.groups = FALSE) expect_equal(length(iff.ids), 2) iff.ids <- all_iff_block_ids(pd, root.only=TRUE, ignore.groups = TRUE) expect_equal(length(iff.ids), 3) iff.ids <- all_iff_block_ids(pd, root.only=FALSE, ignore.groups = FALSE) expect_equal(length(iff.ids), 4) }) #line 234 "/rdtf/parsetools/R/iff_blocks.R" test_that('pd_is_tagged_iff_block', {#!@testing pd <- get_parse_data(parse(text={" if(FALSE){#!@tag } if(F){#@tag } if(F){# @tag } {#!@tag # not an if(F) block } {#@tag } {# @tag } if(FALSE)#@tag not valid FALSE "}, keep.source=TRUE)) tag <- 'tag' id <- roots(pd) expect_equal(length(id), 7) expect_true (pd_is_tagged_iff_block(id[[1]], pd, tag)) expect_true (pd_is_tagged_iff_block(id[[3]], pd, tag, FALSE)) expect_false(pd_is_tagged_iff_block(id[[3]], pd, tag, TRUE )) expect_false(pd_is_tagged_iff_block(id[[6]], pd, tag)) expect_false(pd_is_tagged_iff_block(id[[7]], pd, tag)) expect_equal(pd_is_tagged_iff_block(id, pd, tag) , c(T,T,F,F,F,F,F)) expect_equal(pd_is_tagged_iff_block(id, pd, tag, FALSE) , c(T,T,T,F,F,F,F)) pd <- get_parse_data(parse(text='rnorm(1)', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F)#!@tag not in block\nF', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){FALSE}', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){# @tag\nF\n}', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){#@tag\nF\n}', keep.source=TRUE)) expect_true(pd_is_tagged_iff_block(roots(pd), pd, tag)) }) #line 301 "/rdtf/parsetools/R/iff_blocks.R" test_that('all_tagged_iff_block_ids', {#!@testing pd <- get_parse_data(parse(text={" if(FALSE){#!@tag # yes } if(F){#@tag # yes } if(F){# @tag # determines doc.only parameter } {#!@tag # not an if(F) block } {#@tag # no } {# @tag # no } "}, keep.source=TRUE)) tag <- 'tag' id <- roots(pd) tagged.iff.ids <- all_tagged_iff_block_ids(pd, tag) pd <- get_parse_data(parse(text={" # this has no iff blocks "}, keep.source=TRUE)) tag <- 'tag' tagged.iff.ids <- all_tagged_iff_block_ids(pd, tag) expect_identical(tagged.iff.ids, integer(0)) }) #line 484 "/rdtf/parsetools/R/iff_blocks.R" test_that('iff_associated_name', {#!@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 } setMethod("fun", c("A","B"), function(x,y){ x+y }) if(F){#!@testing #testing a setMethod with multiple signature elements. } 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_null( pd_get_iff_associated_name_id(iff.ids[[1L]], pd), info="iff at beginning") expect_equal( pd_get_iff_associated_name_id(iff.ids[[2L]], pd) , structure("hello_world", type = "function_assignment") , info="iff after function assignment") expect_equal( pd_get_iff_associated_name_id(iff.ids[[3L]], pd) , structure("ldf", type = "assignment") , info="iff after other assignment") expect_equal( pd_get_iff_associated_name_id(iff.ids[[4L]], pd) , structure("f2", type = "function_assignment") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[5L]], pd) , structure("A", type = "setClass") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[6L]], pd) , structure("print,A-method", type = "setMethod") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[7L]], pd) , structure("my_generic", type = "setGeneric") , info="iff after other iff") expect_null ( pd_get_iff_associated_name_id(iff.ids[[8L]], pd) , info="following call") expect_equal( pd_get_iff_associated_name_id(iff.ids[[9L]], pd) , structure("fun,A,B-method", type = "setMethod") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[10L]], pd) , structure("coerce,class1,class2-method", type = "setAs" , from='class1', to='class2' ) , info="setAs") }) #line 573 "/rdtf/parsetools/R/iff_blocks.R" test_that('iff_associated_name errors', {#@testing iff_associated_name errors pd <- get_parse_data(parse(text={' setClass(A) if(F){#@testing #testing a setClass }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(pd) , "Cannot infer Class argument of setClass") pd <- get_parse_data(parse(text={' setMethod(A, "class") if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(pd) , "Cannot infer method name for setMethod.") pd <- get_parse_data(parse(text={' setMethod("show", setClass("A")) if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer signature for setMethod.") pd <- get_parse_data(parse(text={' setMethod("show", A) if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer signature for setMethod.") pd <- get_parse_data(parse(text={' setGeneric(generic, function(x){x}) if(F){#@testing #testing a setGeneric }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer method name for setGeneric.") pd <- get_parse_data(parse(text={' setAs(from, "to") if(F){#@testing #testing a setAs }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer from class for setAs.") pd <- get_parse_data(parse(text={' setAs("from", to) if(F){#@testing #testing a setAs }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer to argument for setAs.") }) parsetools/tests/testthat/test-pd_make_is_in.R0000644000176200001440000000175613334330012021331 0ustar liggesusers#! This file was automatically produced by the documentation package. #! Changes will be overwritten. context('tests extracted from file `pd_make_is_in.R`') #line 39 "/rdtf/parsetools/R/pd_make_is_in.R" test_that('pd_make_is_call & pd_make_is_in_call', {#@test pd_make_is_call & pd_make_is_in_call pd <- get_parse_data(parse(text={" test <- function(msg){ cat('test message:', msg, '\n') } test('my message') "}, keep.source=TRUE)) is_in_test <- pd_make_is_in_call('test') .is <- environment(is_in_test)[['.is']] calls <- environment(is_in_test)[['calls']] test.id <- pd_all_root_ids(pd)[[2]] id <- pd[pd$text=="'my message'",'id'] expect_true(pd_is_symbol_call(test.id, pd)) expect_identical(text(call_symbol(test.id, pd)), 'test') expect_true(.is(test.id, pd)) expect_false(.is(id, pd)) expect_true(is_in_test(id, pd)) expect_true(is_in_test(id, pd)) expect_identical(is_in_test(pd$id, pd=pd), ascend_to_root(pd=pd) == test.id) }) parsetools/tests/testthat/test-pd_classes.R0000644000176200001440000002377713401560544020711 0ustar liggesusers#! This file was automatically produced by the testextra package. #! Changes will be overwritten. context('tests extracted from file `pd_classes.R`') #line 203 "R/pd_classes.R" test_that('pd_class_definitions', {#@testing pd_class_definitions expect_identical(pd_class_definitions$has(), logical(0)) expect_true(pd_class_definitions$has('setClass')) expect_true(pd_class_definitions$has('setRefClass')) expect_false(pd_class_definitions$has('DefineANewClass')) expect_identical( pd_class_definitions$has(c('setClass', 'setRefClass')) , c('setClass'=TRUE, 'setRefClass'=TRUE) ) expect_false(pd_class_definitions$has('not a class definition')) expect_false( pd_class_definitions$has('my_custom_class_definer')) expect_error( pd_class_definitions$add('my_custom_class_definer') , "function `my_custom_class_definer` not found." ) expect_true(pd_class_definitions$add('my_custom_class_definer', .exists=FALSE)) expect_true(pd_class_definitions$has('my_custom_class_definer')) expect_error( pd_class_definitions$add('my_custom_class_definer', .exists=FALSE) , "`my_custom_class_definer` already has a testing function defined." ) pd <- get_parse_data(parse(text={" setClass('S4Test') setRefClass('RefTest') my_custom_class_definer('CustomTest') "}, keep.source=TRUE)) roots <- roots(pd) names.of.definers <- pd_class_definitions$names() expect_identical( names.of.definers , c("my_custom_class_definer", "setClass", "setRefClass") ) results.1.is <- pd_class_definitions$test_is(roots[[1]], pd=pd) expect_identical( results.1.is[names.of.definers] , c("my_custom_class_definer"=FALSE, "setClass"=TRUE, "setRefClass"=FALSE) ) results.is <- pd_class_definitions$test_is(roots, pd=pd) expect_identical( dim(results.is), c(3L,3L) ) expect_equal(rownames(results.is), as.character(roots) ) expect_equal(sort(colnames(results.is)), sort(names.of.definers)) expect_true(pd_class_definitions$test_is_in(.find_text("'S4Test'", pd), pd)['setClass']) expect_false(all(pd_class_definitions$test_is_in(.find_text("'S4Test'", pd), pd))) expect_true(pd_class_definitions$test_is_in(.find_text("'CustomTest'", pd), pd)['my_custom_class_definer']) expect_false(all(pd_class_definitions$test_is_in(.find_text("'CustomTest'", pd), pd))) expect_identical(pd_class_definitions$which(roots[[1]], pd), "setClass") expect_identical(pd_class_definitions$which(.find_text("'S4Test'", pd), pd), character(0)) expect_identical(pd_class_definitions$in_which(roots[[1]], pd), "setClass") expect_identical(pd_class_definitions$in_which(.find_text("'S4Test'", pd), pd), "setClass") expect_null(pd_class_definitions$rm('my_custom_class_definer')) expect_false( pd_class_definitions$has('my_custom_class_definer')) expect_warning( pd_class_definitions$rm('my_custom_class_definer') , "object 'my_custom_class_definer' not found" ) expect_error( pd_class_definitions$add_definition('another_custom') , "function `another_custom` not found." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = NULL , test.in = NULL , .exists=FALSE) , "test.is must be a function." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = NULL , .exists=FALSE) , "test.in must be a function." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = function(){} , .exists=FALSE) , paste( "test.is function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd){} , test.in = function(){} , .exists=FALSE) , "test.is function must accept argument .check or extra arguments `...`" ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = function(){} , .exists=FALSE) , paste( "test.is function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(id, pd){} , .exists=FALSE) , "test.in function must accept argument .check or extra arguments `...`" ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(){} , .exists=FALSE) , paste( "test.in function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_true( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(id, pd, ...){return(TRUE)} , .exists=FALSE) ) expect_true(pd_class_definitions$has('another_custom')) expect_null(pd_class_definitions$rm('another_custom')) expect_false(pd_class_definitions$has('another_custom')) }) #line 337 "R/pd_classes.R" test_that('pd_is_class_definition', {#@test pd <- get_parse_data(parse(text=' setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('"testClass"', pd), pd)) pd <- get_parse_data(parse(text=' setRefClass("mEdit", fields = list( data = "matrix", edits = "list")) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(.find_text("fields", pd), pd)) expect_identical( pd_is_class_definition(c(roots(pd), .find_text("fields", pd)), pd) , c(TRUE, FALSE) ) }) #line 370 "R/pd_classes.R" test_that('object in setClass', {#@test object in setClass pd <- get_parse_data(parse(text=' setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) setMethod("print", "testClass", function(){ cat("This is just a test.") }) ', keep.source=TRUE)) root.id <- roots(pd) id <- .find_text("#< the x field") pd_class_definitions$test_is_in(id, pd) expect_true(pd_is_in_class_definition(id, pd)) id2 <- .find_text('"This is just a test."') expect_false(pd_is_in_class_definition(id2, pd)) pd_class_definitions$test_is_in(c(id, id2), pd) expect_identical(pd_is_in_class_definition(c(id, id2), pd), c(TRUE, FALSE)) }) #line 405 "R/pd_classes.R" test_that('pd_add_class_definition', {#@testing test.is <- pd_make_is_call('setTestClass') test.in <- pd_make_is_in_call('setTestClass', .is = test.is) pd_add_class_definition('setTestClass', test.is, test.in, FALSE, TRUE) pd <- get_parse_data(parse(text=' setTestClass( MyClass, ...) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('MyClass', pd), pd)) pd_class_definitions$rm('setTestClass') }) #line 422 "R/pd_classes.R" test_that('pd_add_class', {#@testing pd_add_class('setAnotherClass', FALSE, TRUE) pd <- get_parse_data(parse(text=' setAnotherClass( "testAnotherClass", ...) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('"testAnotherClass"', pd), pd)) pd_class_definitions$rm('setAnotherClass') }) #line 459 "R/pd_classes.R" test_that('closest_call', {#@testing pd <- get_parse_data(parse(text={" x <- 1 y <- rnorm(10) z <- function(a,b){ cat(a,b) } testClass <- setRefClass('testClass' , fields = list( f1 = 'integer' , f2 = function(){ return(f1) } ) , methods = list( hw = function(){ print('hello world') } ) ) "}, keep.source=TRUE)) roots <- roots(pd) id.10 <- pd[pd$text == '10','id'] expect_equal(text(call_symbol(pd_get_closest_call_id(id.10, pd=pd), pd=pd)), 'rnorm') id.hw <- pd[pd$text == "'hello world'", 'id'] expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd))), 'print') expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd, 'list'))), 'list') expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd, 'setRefClass'))), 'setRefClass') expect_true(is.na(pd_get_closest_call_id(id.hw, pd=pd, 'setClass'))) }) parsetools/tests/testthat.R0000644000176200001440000000016213275063024015573 0ustar liggesusersopar <- options(keep.source=TRUE, keep.source.pkgs=TRUE) library(testthat) test_check("parsetools") options(opar) parsetools/vignettes/0000755000176200001440000000000013643201241014451 5ustar liggesusersparsetools/vignettes/Coding_Conventions.Rmd0000644000176200001440000001100213374664664020726 0ustar liggesusers--- title: "Parsetools Coding Conventions" author: "Andrew Redd" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Parsetools Coding Conventions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` Coding Conventions for the `parsetools` package =============================================== Functions --------- All the functions in `parsetools` are concerned with `parse-data` objects. Functions either obtain the `parse-data`, such as `get_parse_data()`; convert or transform the parse data, such as `classify_comments()`; identify elements of the parse data tree, such as `pd_is_function()`; or navigate the tree, such as `get_parent_id()`. ### Arguments ### With the exception of obtaining functions and manipulation functions, all function will either take an argument `pd` as a stand alone argument which expects a `parse-data` object, or will take the combination of an `id` and a `pd`, exclusively in that order. The `id` argument is expected to be an integer of values that exist in `pd$id` which denotes the node or nodes of interest. Whether id is a singleton or vector is differentiated by function naming conventions described in the following sections. If there is a need for additional function arguments they must occur after the `id` and `pd` arguments. ### Naming Conventions Overview ### Function names should follow the underscore standard with appropriate prefixes and suffixes, and conform to proper plurality. form Meaning Accepts Returns Exported ------------- ------------------------- ---------- --------------------------- ------------ pd_is_* Logical test function id vector logical 1:1 for input id Yes pd_get_*_id Navigation function id vector id integer 1:1 for input Yes pd_get_*_ids Set identification single id id vector many:1 for input Yes get_*_pd Subsetting id(1)+pd subsetted parse-data No all_*_ids Global sets parse-data id vector many:1 for input No pd_* Other action function id+pd Depending ### Logical Test Functions ### Functions of the form `pd_is_` test if the specified id satisfies the criteria for ``. For example, `pd_is_function(id,pd)` tests if the id identifies a function expression, namely the token for id is `expr`, and the token for the firstborn, i.e. child with minimum id, is `FUNCTION`. These also appear in the form `pd_is_in_`. Example, `pd_is_in_class_definition` tests if the expression is nested inside any defined class definition. ### Navigation Functions ### Functions that get a single id relative to the current id follow the format `pd_get__id`, they may accept a vector of inputs and return a vector of outputs, with each element of the output vector corresponding respectively to the input vector. ### Set Identification Functions ### Function that of the form `pd_get__ids` are set identification functions. They take a single node, and only a single node and return a set of nodes relative to the given node. ## Shortcut functions There are several functions that are shortcuts for internal expressions. These should not be exported but may use the shortcut of defining the function to infer the `pd` argument from the parent function environment, `pd=get('pd', parent.frame())`. Exported functions should not utilize this shortcut. The shortcut functions are renamed with the following conventions: - `pd_is_` → `is_` - `pd_get__id` → `` - `pd_get__ids` → `s` or the appropriate plural form. ## Error Checking Exported functions should perform error checking on arguments. This can be made optional by the .check argument, and when used internally the checking should be turned off. ## Tests In testing code blocks results of output should be directly in the `expect_*` function, or stored in an object called `test.object`. ## Vectorization Functions that return a single id value for each input should vectorize over input. When possible keep the shortest form, if explicit vectorization is needed use: if (length(id) > 1L) return(sapply(id, , pd=pd, , .check=FALSE)) Those that return multiple values for each input id accept only only singleton ids. These functions should check that the input is of length 1. parsetools/R/0000755000176200001440000000000013643201241012642 5ustar liggesusersparsetools/R/pd_identify.R0000644000176200001440000000673313643121005015273 0ustar liggesusers# pd_identify.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_identify ========================================================== #' Get the ID for an object #' #' Identify in pd the id for the object given. #' #' @param pd the parse data. #' @param object an object that originated in pd, #' for which to obtain the ID. #' #' @export pd_identify <- function( pd #< parse data , object #< [srcref] object to identify ) UseMethod('pd_identify', object) #' @export #' @describeIn pd_identify Default method identifies by [base::srcref()]. pd_identify.default <- function( pd, object) pd_identify(pd=pd, utils::getSrcref(object)) #' @export #' @describeIn pd_identify Passing a NULL object will result in an error. pd_identify.NULL <- function( pd, object) stop("Invalid object.") #' @export #' @describeIn pd_identify Identify by explicit `srcref`. pd_identify.srcref <- function( pd, object){ stopifnot( inherits(object, 'srcref') , inherits(pd, 'parse-data') ) pd[ pd$line1 == utils::getSrcLocation(object, 'line', TRUE ) & pd$line2 == utils::getSrcLocation(object, 'line', FALSE) & pd$col1 == utils::getSrcLocation(object, 'col' , TRUE) & pd$col2 == utils::getSrcLocation(object, 'col' , FALSE) , 'id' ] } 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){} "} source(file = textConnection(text), local=TRUE, keep.source = TRUE ) parsed <- parse(text=text, keep.source=TRUE) pd <- get_parse_data(parsed) id <- pd_identify(pd, my_function) expected <- parent(.find_text('function')[1]) expect_equal(id, expected) expect_error(pd_identify(pd, NULL)) } parsetools/R/reconstitute.R0000644000176200001440000001242413401560041015516 0ustar liggesusers #' Reconstitute Expressions #' #' Creates expressions and calls from the given #' `id` and parse-data, `pd`. #' @inheritParams pd_get_children_ids #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-reconstitute.R pd_reconstitute <- local({ NUM_CONST <- function(id, pd=get('pd', parent.frame())){ t <- text(id) if (t == "TRUE") return(TRUE) else if (t == "FALSE") return(FALSE) else if (substr(t, nchar(t), nchar(t)) == 'L') return(as.integer(substr(t, 0L, nchar(t) - 1L))) as.numeric(t) } STR_CONST <- function(id, pd=get('pd', parent.frame())) unquote(text(id)) SYMBOL_FORMALS <- function(id, pd=get('pd', parent.frame())) as.name(text(id)) SYMBOL_FUNCTION_CALL <- function(id, pd=get('pd', parent.frame())){ call.id <- parent(parent(id)) call.name <- text(call_symbol(call.id)) args <- call_args(call.id) recon.args <- lapply(args, reconstitute, pd=pd) as.call(c(as.name(call.name), recon.args)) } "'('" <- function(id, pd=get('pd', parent.frame())){ reconstitute(next_sibling(id)) } "'{'" <- function(id, pd=get('pd', parent.frame())){ sibs <- utils::head(siblings(id), -1) exprs <- lapply(sibs[-1], reconstitute, pd=pd) as.call(c(as.name('{'), exprs)) } LEFT_ASSIGN <- function(id, pd=get('pd', parent.frame())){ kids <- children(id) name <- reconstitute(next_sibling(id)) value <- reconstitute(next_sibling(next_sibling(id))) call('<-', name, value) } SYMBOL <- function(id, pd=get('pd', parent.frame())){ as.symbol(text(id)) } expr <- function(id, pd=get('pd', parent.frame())){ reconstitute(firstborn(id)) } FUNCTION <- function(id, pd=get('pd', parent.frame())){ sibs <- siblings(id, pd) args <- sibs[2:(length(sibs)-2)] args <- split(args, cumsum(token(args) %in% c("'('", "','"))) names <- sapply(args, function(.)text(.)[token(.) == 'SYMBOL_FORMALS']) recon.args <- sapply(args, function(.){ if(length(.) <= 2) alist(x=)$x else if(any(token(.) == 'SYMBOL_FORMALS')) expr(.[token(.)=='expr']) }) names(recon.args) <- names body.id <- sibs[length(sibs)] stopifnot(token(body.id) == 'expr') fun.body <- expr(body.id) call(text(id), as.pairlist(recon.args), fun.body) } "'!'" <- function(id, pd=get('pd', parent.frame())){ call('!', reconstitute(next_sibling(id))) } IF <- function(id, pd=get('pd', parent.frame())){ n <- length(siblings(id)) if(n==5){ call( 'if' , reconstitute(if_predicate(parent(id))) , reconstitute(if_branch(parent(id))) ) } else if (n==7){ call( 'if' , reconstitute(if_predicate(parent(id))) , reconstitute(if_branch(parent(id))) , reconstitute(if_alternate(parent(id))) ) } else stop("ill-formed if statement") } recon.env <- environment() reconstitute <- function(id, pd=get('pd', parent.frame())){ fun <- get(token(id), mode='function', envir=recon.env, inherits=FALSE) fun(id=id, pd=pd) } function(id, pd, .check=TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } reconstitute(id=id, pd=pd) } }) reconstitute <- internal(pd_reconstitute) if(F){#@testing pd <- get_parse_data(parse(text='rnorm(10L, mean=0, sd=1)', keep.source=TRUE)) id <- roots(pd) x <- substitute(rnorm(10L, mean=0, sd=1)) expect_identical( reconstitute(id), x) pd <- get_parse_data(p <- parse(text="'pd'", keep.source=TRUE)) expect_identical( reconstitute(roots(pd)) , substitute('pd') ) pd <- get_parse_data(p <- parse(text='get(\'pd\', parent.frame())', keep.source=TRUE)) expect_identical( reconstitute(roots(pd)) , substitute(get('pd', parent.frame()), emptyenv()) ) pd <- get_parse_data(parse(text={' function(id, pd=get(\'pd\', parent.frame())){ fb <- firstborn(id) reconstitute(fb) } '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- reconstitute(id, pd) expect_is(reconstituted, 'call') expected <- quote(function(id, pd=get('pd', parent.frame())){ fb <- firstborn(id) reconstitute(fb) }) expect_equal(reconstituted, expected) } if(FALSE){#@test reconstitute if statements} pd <- get_parse_data(parse(text={' if (TRUE) "YES" else "NO" '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- pd_reconstitute(id, pd) expect_is(reconstituted, 'if') expected <- quote(if (TRUE) "YES" else "NO") expect_equal(reconstituted, expected) pd <- get_parse_data(parse(text={' if (TRUE) "YES" '}, keep.source=TRUE)) id <- roots(pd) reconstituted <- pd_reconstitute(id, pd) expect_is(reconstituted, 'if') expected <- quote(if (TRUE) "YES") expect_equal(reconstituted, expected) } parsetools/R/zzz.R0000644000176200001440000000444613373623126013644 0ustar liggesusers #' @exportPattern ^pd_.* list() utils::globalVariables(c('id', 'pd')) formal_arg_is_missing <- function(x)identical(x, alist(x=)$x) if(FALSE){#! @test export compliance grep('^all_', getNamespaceExports('parsetools'), value=TRUE) %>% grep('_ids', ., value=TRUE, invert=TRUE) grep('^get_', getNamespaceExports('parsetools'), value=TRUE) %>% grep("ids$",., value=TRUE, invert = TRUE) %>% grep("^get_parse_data", ., value=TRUE, invert=TRUE) grep('^is_', getNamespaceExports('parsetools'), value=TRUE) %>% grep('\\.(data\\.frame|parse-data|character)$', ., invert=TRUE, value=TRUE) names.pd_is_ <- grep('pd_is_', getNamespaceExports('parsetools'), value=TRUE) for(i in seq_along(names.pd_is_)){ name <- names.pd_is_[[i]] f <- get(name, asNamespace('parsetools')) args <- formals(f) id.present <- match('id' , names(args)) pd.present <- match('pd' , names(args)) check.present <- match('.check', names(args)) if (!is.na(id.present)){ expect_true( formal_arg_is_missing(args$id) , paste0( "argument `id` for function '", names.pd_is_[[i]], "' " , " should not have a default." ) ) expect_equal(id.present, 1L) } if (!is.na(pd.present)){ expect_true( formal_arg_is_missing(args$pd) , paste0( "argument `pd` for function '", names.pd_is_[[i]], "' " , " should not have a default." ) ) expect_equal(pd.present, if (id.present) 2L else 1L) } if (!is.na(check.present)) { expect_true( identical(args$.check, TRUE) , paste0( "argument `.check` for function '", names.pd_is_[[i]], "' " , " should default to `TRUE`." ) ) if (pd.present) expect_true(pd.present < check.present) } else if (!is.na(pd.present)) fail(paste0('if argument `pd` is present argument `.check` is required to be present' , " for exported function '", names.pd_is_[[i]], "'.")) } } parsetools/R/pd_classes.R0000644000176200001440000004701513401550520015113 0ustar liggesusers#' @include pd_make_is_in.R #' @title Test for Class Definitions #' #' @usage #' pd_class_definitions #' @param name name of the class defining function #' @param .exists require the function to exists to add. #' @param .overwrite if TRUE allows for overwriting existing test functions. #' @param test.is function accepting arguments `id` and `pd` which #' tests if given `id` is associated with the defined #' class defining functions. #' @param test.in function accepting arguments `id` and `pd` which #' tests if given `id` is contained in the defined #' class defining functions. #' @param id id(s) to test. #' @param pd parse data which contains id. #' @param .check should the id, and pd be checked? #' #' @description #' These function manage adding class defining functions and #' testing if an id is associated with a class definition or #' if is contained in the class definition. #' #' @details #' #' \subsection{\code{pd_class_definitions$has}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$has(name) #' }} #' Check if a class defining function has #' 'is' and 'in' function defined for it. #' } #' \subsection{\code{pd_class_definitions$add} or \code{pd_add_class}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$add(name, .exists=TRUE, .overwrite=FALSE) #' #' pd_add_class(name, .exists=TRUE, .overwrite=FALSE) #' }} #' Add a def with default 'is' and 'in' functions defined. #' } #' \subsection{\code{pd_class_definitions$add_definition} or \code{pd_add_class_definition}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$add_definition(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE) #' #' pd_add_class_definition(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE) #' }} #' Add a class defining function with custom 'is' and 'in' functions defined. #' } #' \subsection{\code{pd_class_definitions$rm}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$rm(name) #' }} #' Remove the testing functions for the class. #' } #' \subsection{\code{pd_class_definitions$names}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$names() #' }} #' Return a vector of the classed for which tests are defined. #' } #' \subsection{\code{pd_class_definitions$test_is}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$test_is(id, pd, check=TRUE) #' }} #' Test if \code{id} is associated with each of #' defined class definitions. #' } #' \subsection{\code{pd_class_definitions$test_is_in}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$test_is_in(id, pd, check=TRUE) #' }} #' Test if \code{id} is contained within each of #' defined class definitions. #' } #' \subsection{\code{pd_class_definitions$which}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$which(id, pd, check=TRUE) #' }} #' Return the name of the class, if any, #' which \code{id} corresponds to. #' } #' \subsection{\code{pd_class_definitions$in_which}}{ #' \subsection{Usage}{\preformatted{ #' pd_class_definitions$in_which(id, pd, check=TRUE) #' }} #' Returns a vector of the classes, if any, #' of the classes which \code{id} is contained in. #' } #' \subsection{\code{pd_is_class_definition}}{ #' Returns \code{TRUE} if the id corresponds to any of the #' class defining calls. #' } #' #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-classes.R pd_class_definitions <- new.env(hash=TRUE) local(envir=pd_class_definitions, { .is <- new.env(hash=TRUE, parent=emptyenv()) .is_in <- new.env(hash=TRUE, parent=emptyenv()) .call_test <- function(fun, ...)fun(...) has <- function(name){ if (missing(name) || length(name) == 0) return(logical(0)) if (length(name) > 1L) return(sapply(name, has)) exists(name, envir=.is, mode='function', inherits=FALSE) } add <- function( name, .exists=TRUE, .overwrite=FALSE){ if (length(name) > 1L) return(invisible(structure( lapply( name, add , .exists=.exists , .overwrite=.overwrite ) , names = name ))) if (.exists && !exists(name)) stop("function `", name, "` not found.") if (!.overwrite && has(name)) stop("`", name, "` already has a testing function defined.") test.is <- pd_make_is_call(name) test.in <- pd_make_is_in_call(name, .is = test.is) assign(name, test.is, envir = .is) assign(name, test.in, envir = .is_in) return(invisible(TRUE)) } add_definition <- function(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE){ if (.exists && !exists(name)) stop("function `", name, "` not found.") if (!.overwrite && has(name)) stop("`", name, "` already has a testing function defined.") if (!inherits(test.is, 'function')) stop("test.is must be a function.") if (!inherits(test.in, 'function')) stop("test.in must be a function.") if (!identical(match(c('id', 'pd'), base::names(formals(test.is))), 1:2)) stop(paste( "test.is function must accept arguments 'id' and 'pd'" , "as the first two arguments.")) if (!('.check' %in% base::names(formals(test.is)) || "..." %in% base::names(formals(test.is)))) stop( "test.is function must accept argument .check or extra arguments `...`") if (!identical(match(c('id', 'pd'), base::names(formals(test.in))), 1:2)) stop(paste( "test.in function must accept arguments 'id' and 'pd'" , "as the first two arguments.")) if (!('.check' %in% base::names(formals(test.in)) || "..." %in% base::names(formals(test.in)))) stop( "test.in function must accept argument .check or extra arguments `...`") assign(name, test.is, envir = .is) assign(name, test.in, envir = .is_in) return(invisible(TRUE)) } rm <- function(name){ base::rm(list=name, envir=.is , inherits = FALSE) base::rm(list=name, envir=.is_in, inherits = FALSE) } test_is <- function( id, pd, .check=TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) == 0) return(logical(0)) else if (length(id) > 1L) { value <- sapply(id, test_is, pd=pd) return(structure( t(value) , dimnames = list(id = id, rownames(value)) )) } else sapply(.is, .call_test, id=id, pd=pd, .check=FALSE)[names()] } test_is_in <- function( id, pd, .check=TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) == 0) return(logical(0)) else if (length(id) > 1L){ value <- sapply(id, test_is_in, pd=pd) return(structure( t(value) , dimnames = list(id = id, rownames(value)) )) } else sapply(.is_in, .call_test, id=id, pd=pd, .check=FALSE)[names()] } names <- function(sorted=TRUE) objects(.is, sorted=sorted) which <- function( id, pd, .check = TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } stopifnot(length(id) == 1L) base::names(base::which(test_is(id=id, pd=pd, .check=FALSE))) } in_which <- function( id, pd, .check = TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } stopifnot(length(id) == 1L) base::names(base::which(test_is_in(id=id, pd=pd, .check=FALSE))) } }) lockEnvironment(pd_class_definitions, TRUE) pd_class_definitions$add(c('setClass', 'setRefClass')) if(FALSE){#@testing pd_class_definitions expect_identical(pd_class_definitions$has(), logical(0)) expect_true(pd_class_definitions$has('setClass')) expect_true(pd_class_definitions$has('setRefClass')) expect_false(pd_class_definitions$has('DefineANewClass')) expect_identical( pd_class_definitions$has(c('setClass', 'setRefClass')) , c('setClass'=TRUE, 'setRefClass'=TRUE) ) expect_false(pd_class_definitions$has('not a class definition')) expect_false( pd_class_definitions$has('my_custom_class_definer')) expect_error( pd_class_definitions$add('my_custom_class_definer') , "function `my_custom_class_definer` not found." ) expect_true(pd_class_definitions$add('my_custom_class_definer', .exists=FALSE)) expect_true(pd_class_definitions$has('my_custom_class_definer')) expect_error( pd_class_definitions$add('my_custom_class_definer', .exists=FALSE) , "`my_custom_class_definer` already has a testing function defined." ) pd <- get_parse_data(parse(text={" setClass('S4Test') setRefClass('RefTest') my_custom_class_definer('CustomTest') "}, keep.source=TRUE)) roots <- roots(pd) names.of.definers <- pd_class_definitions$names() expect_identical( names.of.definers , c("my_custom_class_definer", "setClass", "setRefClass") ) results.1.is <- pd_class_definitions$test_is(roots[[1]], pd=pd) expect_identical( results.1.is[names.of.definers] , c("my_custom_class_definer"=FALSE, "setClass"=TRUE, "setRefClass"=FALSE) ) results.is <- pd_class_definitions$test_is(roots, pd=pd) expect_identical( dim(results.is), c(3L,3L) ) expect_equal(rownames(results.is), as.character(roots) ) expect_equal(sort(colnames(results.is)), sort(names.of.definers)) expect_true(pd_class_definitions$test_is_in(.find_text("'S4Test'", pd), pd)['setClass']) expect_false(all(pd_class_definitions$test_is_in(.find_text("'S4Test'", pd), pd))) expect_true(pd_class_definitions$test_is_in(.find_text("'CustomTest'", pd), pd)['my_custom_class_definer']) expect_false(all(pd_class_definitions$test_is_in(.find_text("'CustomTest'", pd), pd))) expect_identical(pd_class_definitions$which(roots[[1]], pd), "setClass") expect_identical(pd_class_definitions$which(.find_text("'S4Test'", pd), pd), character(0)) expect_identical(pd_class_definitions$in_which(roots[[1]], pd), "setClass") expect_identical(pd_class_definitions$in_which(.find_text("'S4Test'", pd), pd), "setClass") expect_null(pd_class_definitions$rm('my_custom_class_definer')) expect_false( pd_class_definitions$has('my_custom_class_definer')) expect_warning( pd_class_definitions$rm('my_custom_class_definer') , "object 'my_custom_class_definer' not found" ) expect_error( pd_class_definitions$add_definition('another_custom') , "function `another_custom` not found." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = NULL , test.in = NULL , .exists=FALSE) , "test.is must be a function." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = NULL , .exists=FALSE) , "test.in must be a function." ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = function(){} , .exists=FALSE) , paste( "test.is function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd){} , test.in = function(){} , .exists=FALSE) , "test.is function must accept argument .check or extra arguments `...`" ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(){} , test.in = function(){} , .exists=FALSE) , paste( "test.is function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(id, pd){} , .exists=FALSE) , "test.in function must accept argument .check or extra arguments `...`" ) expect_error( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(){} , .exists=FALSE) , paste( "test.in function must accept arguments 'id' and 'pd'" , "as the first two arguments." ) ) expect_true( pd_class_definitions$add_definition('another_custom' , test.is = function(id, pd, ...){return(TRUE)} , test.in = function(id, pd, ...){return(TRUE)} , .exists=FALSE) ) expect_true(pd_class_definitions$has('another_custom')) expect_null(pd_class_definitions$rm('another_custom')) expect_false(pd_class_definitions$has('another_custom')) } pd_is_class_definition <- function(id, pd, .check=TRUE){ #' @rdname pd_class_definitions if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, pd_is_class_definition, pd=pd, .check=FALSE)) any(pd_class_definitions$test_is(id, pd)) } if(FALSE){#@test pd <- get_parse_data(parse(text=' setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('"testClass"', pd), pd)) pd <- get_parse_data(parse(text=' setRefClass("mEdit", fields = list( data = "matrix", edits = "list")) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(.find_text("fields", pd), pd)) expect_identical( pd_is_class_definition(c(roots(pd), .find_text("fields", pd)), pd) , c(TRUE, FALSE) ) } pd_is_in_class_definition <- function(id, pd, .check = TRUE){ #' @rdname pd_class_definitions if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, pd_is_in_class_definition, pd=pd, .check=FALSE)) any(pd_class_definitions$test_is_in(id, pd)) } if(FALSE){#@test object in setClass pd <- get_parse_data(parse(text=' setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) setMethod("print", "testClass", function(){ cat("This is just a test.") }) ', keep.source=TRUE)) root.id <- roots(pd) id <- .find_text("#< the x field") pd_class_definitions$test_is_in(id, pd) expect_true(pd_is_in_class_definition(id, pd)) id2 <- .find_text('"This is just a test."') expect_false(pd_is_in_class_definition(id2, pd)) pd_class_definitions$test_is_in(c(id, id2), pd) expect_identical(pd_is_in_class_definition(c(id, id2), pd), c(TRUE, FALSE)) } pd_add_class_definition <- function(name, test.is, test.in, .exists=TRUE, .overwrite=FALSE){ #' @rdname pd_class_definitions pd_class_definitions$add_definition( name=name, test.is=test.is, test.in=test.in , .exists=.exists, .overwrite=.overwrite) } if(FALSE){#@testing test.is <- pd_make_is_call('setTestClass') test.in <- pd_make_is_in_call('setTestClass', .is = test.is) pd_add_class_definition('setTestClass', test.is, test.in, FALSE, TRUE) pd <- get_parse_data(parse(text=' setTestClass( MyClass, ...) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('MyClass', pd), pd)) pd_class_definitions$rm('setTestClass') } pd_add_class <- function(name, .exists=TRUE, .overwrite=FALSE){ #' @rdname pd_class_definitions pd_class_definitions$add(name=name, .exists=.exists, .overwrite=.overwrite) } if(FALSE){#@testing pd_add_class('setAnotherClass', FALSE, TRUE) pd <- get_parse_data(parse(text=' setAnotherClass( "testAnotherClass", ...) ', keep.source=TRUE)) expect_true(pd_is_class_definition(id = roots(pd), pd)) expect_false(pd_is_class_definition(id = .find_text('"testAnotherClass"', pd), pd)) pd_class_definitions$rm('setAnotherClass') } #' @title Get the closest call ID. #' @inheritParams pd_is_symbol_call #' @param calls optional calls to limit consideration to. #' @description #' Get the id of the call that is closest to the \code{id} given. #' Closest is defined as the innermost call that contains the \code{id}. #' pd_get_closest_call_id <- function( id, pd, calls = NULL, .check=TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(is.null(calls) || is.character(calls)) } if (length(id) > 1L) return(sapply(id, pd_get_closest_call_id, pd=pd, calls=calls)) # nocov all.ancestors <- ancestors(id, pd, only.present=TRUE) call.ancestors <- all.ancestors[is_symbol_call(all.ancestors)] if (length(call.ancestors) == 0 ) return(NA_integer_) # nocov if (length(calls)) call.ancestors <- call.ancestors[text(call_symbol(call.ancestors)) %in% calls] if (length(call.ancestors) == 0 ) return(NA_integer_) call.ancestors[[1]] } closest_call <- internal(pd_get_closest_call_id) if(FALSE){#@testing pd <- get_parse_data(parse(text={" x <- 1 y <- rnorm(10) z <- function(a,b){ cat(a,b) } testClass <- setRefClass('testClass' , fields = list( f1 = 'integer' , f2 = function(){ return(f1) } ) , methods = list( hw = function(){ print('hello world') } ) ) "}, keep.source=TRUE)) roots <- roots(pd) id.10 <- pd[pd$text == '10','id'] expect_equal(text(call_symbol(pd_get_closest_call_id(id.10, pd=pd), pd=pd)), 'rnorm') id.hw <- pd[pd$text == "'hello world'", 'id'] expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd))), 'print') expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd, 'list'))), 'list') expect_equal(text(call_symbol(pd_get_closest_call_id(id.hw, pd=pd, 'setRefClass'))), 'setRefClass') expect_true(is.na(pd_get_closest_call_id(id.hw, pd=pd, 'setClass'))) } parsetools/R/testing_blocks.R0000644000176200001440000002712613643121043016010 0ustar liggesusers{####################################################################### # 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 `` 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 :2:5" , info = "cannot find name for block" ) expect_equal( extract_test_block(iff.ids[[2L]], pd) , structure(c( '#line 9 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , '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 ""' , 'test_that(\'hello_world\', {#!@testthat' , ' expect_output(hello_world(), "hello world")' , ' })' , '#line 14 ""' , '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 ""' , '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 \"\"" , "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.") } parsetools/R/pd_make_is_in.R0000644000176200001440000000344513325456055015570 0ustar liggesusers #' Create a function to test if an id is contained in a type #' #' @param calls The tokens to test against #' @param .is A function to test if a specific id is a valid #' #@internal pd_make_is_in_call <- function(calls, .is=pd_make_is_call(calls)){ force(.is) me <- function( id, pd, .check=TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1) return(sapply(id, me, pd=pd)) my.ancestors <- ancestors(id, pd, only.present=TRUE) any(.is(id=my.ancestors, pd=pd, .check=FALSE)) } } #' @rdname pd_make_is_in_call #@internal pd_make_is_call <- function(calls){ stopifnot( length(calls) > 0 , is.character(calls) ) me <- function(id, pd, .check=TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, me, pd=pd, .check=FALSE)) is_symbol_call(id, pd) && text(call_symbol(id, pd)) %in% calls } } if(FALSE){#@test pd_make_is_call & pd_make_is_in_call pd <- get_parse_data(parse(text={" test <- function(msg){ cat('test message:', msg, '\n') } test('my message') "}, keep.source=TRUE)) is_in_test <- pd_make_is_in_call('test') .is <- environment(is_in_test)[['.is']] calls <- environment(is_in_test)[['calls']] test.id <- pd_all_root_ids(pd)[[2]] id <- pd[pd$text=="'my message'",'id'] expect_true(pd_is_symbol_call(test.id, pd)) expect_identical(text(call_symbol(test.id, pd)), 'test') expect_true(.is(test.id, pd)) expect_false(.is(id, pd)) expect_true(is_in_test(id, pd)) expect_true(is_in_test(id, pd)) expect_identical(is_in_test(pd$id, pd=pd), ascend_to_root(pd=pd) == test.id) } parsetools/R/tags.R0000644000176200001440000002252713643121034013734 0ustar liggesusers{####################################################################### # tags.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/. # }####################################################################### #@internal make_tag_regex <- function( tag #< tag pattern, interpreted as a regular expression #^ or alternatives if more that one is passed in. , ... #< discarded ){ if(length(tag)>1) tag <- paste0("(", paste(tag, collapse="|"), ")") paste(comment.classes$prefix, collapse='|') paste0( "(?<=#|#'|#!|#<|\\s|^)" , "@", tag , "\\b" ) } if(FALSE){#!@ tag <- 'tag' cases <- c( '#@tag', '# @tag' , '@tag' # TRUE , '@@tag' # maybe? , '#@ tag', 'tag', 'aname@tag.org' # FALSE ) expect_equal(rx <- make_tag_regex(tag), "(?<=#|#'|#!|#<|\\s|^)@tag\\b") expect_equal( grepl(rx, cases, perl=TRUE) , c(T, T, T, F, F, F, F) ) other.cases <- gsub('tag', 'another', cases) expect_equal( rx <- make_tag_regex(c('tag', 'another')) , "(?<=#|#'|#!|#<|\\s|^)@(tag|another)\\b" ) expect_equal( grepl(rx, c(cases, other.cases), perl=TRUE) , c( c(T, T, T, F, F, F, F) , c(T, T, T, F, F, F, F) ) ) edge.cases <- c('#\'@tag', '#!@tag', '#<@tag', '#@tag') expect_true(all(grepl(rx, edge.cases, perl=TRUE))) } #' @title Check if there is a documentation `@` tag. #' @inheritParams pd_get_children_ids #' @param tag tag(s) to test for #' @param ... options passed on pd_has_tag <- function( id, pd, tag, ...){ #' @description #' #' Check if a node of \code{parse-data} identified by \code{id} #' is both a comment and contains a documentation tag identified by #' the `@` symbol. tag.rx <- make_tag_regex(tag, ...) pd_is_comment(id, pd) & grepl(tag.rx, text(id, pd), perl=TRUE, ignore.case=TRUE) } if(FALSE){#!@testing # Note that testthat:::test_code will strip comments from code # this requires a parse statement. pd <- get_parse_data(parse(text='fun <- function(object){ #! function with only comment lines #! @tag TRUE #! @@tag FALSE #! @notag{@tag}@ FALSE # @tag TRUE, even though a regular comment object @tag NULL }', keep.source=TRUE)) tag <- 'tag' id <- pd$id expect_equal(sum(pd_has_tag(id, pd, tag)), 2) } #@internal has_tag <- function(id=pd$id, tag='', pd=get("pd", parent.frame())){ pd_has_tag(id, pd, tag) } if(FALSE){#@testing pd <- parsetools::get_parse_data(parse(text={" if(FALSE){#@block block content #' @first first content #' @second second content #' not part of second content. #' @last } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 4L) } #@ internal clean_tag_comments <- function( x , tag ){ #' @title clean tag comments #' @inheritParams strip_tag #' @description #' replaces '\code{#@tag}' with '\code{#! @tag}' tag <- paste0("(", paste(tag, collapse="|"), ")") gsub(paste0("^#@", tag, "\\b"), "#! @\\1", x) } if(FALSE){#!@testing expect_equal( clean_tag_comments("#@testing", "testing") , "#! @testing" ) } strip_tag <- function( x #< text to strip from , tag #< tag to remove , ... #< passed on options. ){ #' @title Remove a tag that identified a line. #' @param x text to strip from #' @param tag tag(s) to remove #' @param ... passed on options] #' @description #' Removes \code{@tag} tags from the text. #' Also will remove '\code{#@tag}' replacing with '\code{#!}'. pattern <- paste0(make_tag_regex(tag, ...), '\\s*') x <- clean_tag_comments(x, tag) gsub( pattern=pattern, replacement='', x , perl=TRUE, ignore.case=TRUE) #< @return text with the @ tag removed. } if(FALSE){#! @testthat expect_equal( strip_tag("@tag should be removed", 'tag') , "should be removed") expect_equal( strip_tag("@nomd{@tag}@ should not be removed", 'tag') , "@nomd{@tag}@ should not be removed") expect_equal( strip_tag("@@tag should not be removed.", 'tag') , "@@tag should not be removed.") } pd_get_tagged_comment_ids <- function( pd, tag , doc.only = TRUE #< Restrict to documentation comments only? ){ #' @title Get tagged comment ids #' @inheritParams pd_has_tag #' @param doc.only Restrict to documentation comments only? #' @description #' Finds all ids that are comments and contain the given '@' \code{tag}. #' If doc.only is true(default) then only documentation comments are #' considered, otherwise all comments are examined. ids <- if (doc.only) all_doc_comment_ids() else all_comment_ids() ids[pd_has_tag(ids, pd, tag)] #' @return an integer vector of ids. } if(FALSE){#!@testing pd <- parsetools::get_parse_data(parse(text={" fun <- function(object){ #! function with only comment lines #! @tag TRUE #! @@tag FALSE #! @notag{@tag}@ FALSE # @tag TRUE, even though a regular comment object @tag NULL } "}, keep.source=TRUE)) tag <- 'tag' id <- pd$id expect_equal(pd_get_tagged_comment_ids(pd, tag, TRUE ), 15L ) expect_equal(pd_get_tagged_comment_ids(pd, tag, FALSE), c(15L, 21L)) } #' Get the content of a tag #' #' @inheritParams pd_has_tag #' #' @param all.contiguous if TRUE get all comments connected to this element. #' @export pd_get_comment_tag_content <- function(id, pd, tag, all.contiguous=FALSE){ stopifnot( all(is_doc_comment(id, pd)) , all(pd_has_tag(id, pd, tag)) ) if (all.contiguous){ ids <- id repeat{ ns <- next_sibling(id) if (token(id) != token(ns)) break if (has_tag(ns)) break if (start_line(ns) != end_line(id) + 1L) break ids <- c(ids, ns) id <- ns } trimws(strip_doc_comment_leads(strip_tag(text(ids), tag))) } else { trimws(strip_doc_comment_leads(strip_tag(text(id), tag))) } } if(FALSE){#@testing pd <- parsetools::get_parse_data(parse(text={" if(FALSE){#@block block content #' @first first content #' @second second content #' not part of second content. #' @last } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 4L) block.id <- pd_get_tagged_comment_ids(pd, 'block') expect_identical( pd_get_comment_tag_content(block.id, pd, 'block') , "block content") expect_error( pd_get_comment_tag_content(block.id, pd, 'invalid')) first.id <- pd_get_tagged_comment_ids(pd, 'first') expect_identical( pd_get_comment_tag_content(first.id, pd, 'first') , "first content") second.id <- pd_get_tagged_comment_ids(pd, 'second') expect_identical( pd_get_comment_tag_content(second.id, pd, 'second') , "second content") expect_identical( pd_get_comment_tag_content(second.id, pd, 'second', all.contiguous = TRUE) ,c( "second content", "not part of second content.")) last.id <- pd_get_tagged_comment_ids(pd, 'last') expect_identical( pd_get_comment_tag_content(last.id, pd, 'last') , "") } if(FALSE){#@testing edge cases pd <- parsetools::get_parse_data(parse(text={" f <- function(){ #' @testtag comment lines #' That aren't contiguous. #' because they are separated by a blank line. #' @testtag2 These are contiguous #' #' Because the line separating them is #' a documentation comment itself. print('hello world') #' and testtag2 ends due to an expression. } "}, keep.source=TRUE)) expect_equal(sum(has_tag()), 2L) id <- pd_get_tagged_comment_ids(pd, 'testtag') expect_identical( pd_get_comment_tag_content(id, pd, 'testtag', TRUE) , "comment lines") id <- pd_get_tagged_comment_ids(pd, 'testtag2') expect_identical( pd_get_comment_tag_content(id, pd, 'testtag2', TRUE) , c( "These are contiguous" , "" , "Because the line separating them is" , "a documentation comment itself." )) } parsetools/R/parent.R0000644000176200001440000001623513643120730014270 0ustar liggesusers# parent.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/. # #_____________________________________________________________________# #' @describeIn family-nodes Get the parent of `id`. pd_get_parent_id <- function(id, pd, .check=TRUE) { if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd, FALSE) } pd[match(id, pd$id), 'parent'] } parent <- internal(pd_get_parent_id) if(FALSE){#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) expect_identical(pd_get_parent_id(1, pd), 3L) expect_is(pd_get_parent_id(1, pd), "integer") expect_is(pd_get_parent_id(10000, pd), "integer", info="missing parent") expect_identical(pd_get_parent_id(10000, pd), NA_integer_, info="missing parent") expect_identical(pd_get_parent_id(pd$id, pd), pd$parent) expect_identical(pd_get_parent_id(0L, pd), NA_integer_) } #' @describeIn family-nodes Get the ancestors of `id`. #' @param last The last acceptable parent. #' @param only.present should the list be restricted to only those #' node that are present? Most relevant for #' when parent is zero. #' pd_get_ancestor_ids <- function( id, pd , ngenerations = Inf , aggregate = TRUE , include.self = TRUE , only.present = FALSE , last = 0L , .check = TRUE ){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( ngenerations >= 0 , include.self || (ngenerations > 0) , length(id) == 1L ) } if (ngenerations == 0 && include.self) return (id) if (aggregate) ancestors <- if (include.self) id else integer(0) while(ngenerations > 0L){ ngenerations <- ngenerations - 1 parent <- parent(id, pd) if (is.na(parent)) break # nocov if (only.present && !parent %in% pd$id){ parent <- id break } if (aggregate) ancestors <- c(ancestors, parent) if (parent==last) break id <- parent } if (aggregate) ancestors else parent } ancestors <- internal(pd_get_ancestor_ids) if(FALSE){#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) id <- pd$id[pd$text=='rnorm'] #< Text ID sym <- parent(id) #< Call identifier ID exp <- parent(sym) #< Root expression id expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=TRUE , include.self=TRUE , only.present = FALSE), c(id, sym, exp,0L), info = "defaults, but fully specified.") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=TRUE , include.self=FALSE, only.present = FALSE), c( sym, exp,0L), info = "include.self=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=TRUE , include.self=FALSE, only.present = FALSE), c( sym, exp ), info = "ngenerations=2, include.self=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=TRUE , include.self=TRUE , only.present = FALSE), c(id, sym, exp ), info = "ngenerations=2, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 2 , aggregate=FALSE, include.self=FALSE, only.present = FALSE), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 0 , aggregate=FALSE, include.self=TRUE , only.present = FALSE), id , info = "ngenerations=0, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations= 0 , aggregate=TRUE , include.self=TRUE , only.present = FALSE), id , info = "ngenerations=0, include.self=TRUE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = FALSE), 0L , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids( id, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = TRUE ), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids(exp, pd, ngenerations=Inf, aggregate=FALSE, include.self=FALSE, only.present = TRUE ), exp , info = "ngenerations= 2, aggregate=FALSE") expect_identical(pd_get_ancestor_ids(exp, pd, ngenerations=Inf, aggregate=TRUE , include.self=FALSE, only.present = TRUE ), integer(0) , info = "ngenerations= 2, aggregate=FALSE") expect_error(pd_get_ancestor_ids(id, pd, ngenerations= 0, include.self=FALSE)) expect_error(pd_get_ancestor_ids(id, pd, ngenerations= -1)) expect_error( pd_get_ancestor_ids(1:2, pd) , "length\\(id\\) == 1L is not TRUE" ) } if(FALSE){#! @testing last parameter pd <- get_parse_data(parse(text = ' function(){ setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) ) }', keep.source=TRUE)) root.id <- roots(pd) body.id <- parent(.find_text('{')) id <- .find_text("#< the x field") expect_true(root.id %in% pd_get_ancestor_ids(id, pd)) expect_false(root.id %in% pd_get_ancestor_ids(id, pd, last=body.id)) id2 <- pd[pd$text=="#< the y field", 'id'] expect_error(pd_get_ancestor_ids(c(id, id2), pd, last = body.id, include.self =FALSE)) expect_identical( pd_get_ancestor_ids(id , pd, last = body.id, include.self =FALSE) , ancestors (id2, pd, last = body.id, include.self =FALSE) ) test.object <- pd_get_ancestor_ids(id, pd, last = body.id, include.self =FALSE) expect_false(root.id %in% test.object) } parsetools/R/firstborn.R0000644000176200001440000000557713643120677015030 0ustar liggesusers# firstborn.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/. # #_____________________________________________________________________# #' @include internal.R #' @describeIn family-nodes Test if `id` is firstborn. pd_is_firstborn <- function(id, pd, .check=TRUE){ #' @inheritParams pd_get_children_ids #' @description #' Test if an expression is the firstborn, i.e. oldest or lowest id. if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } id == firstborn(parent(id, pd), pd) } #' @describeIn family-nodes Get the firstborn child of `id`. pd_get_firstborn <- function(id, pd, .check=TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, pd_get_firstborn, pd=pd)) kids <- children(id=id, pd=pd) if (length(kids)==0 ) return(NA_integer_) else min(kids) } #@internal firstborn <- internal(pd_get_firstborn) if(FALSE){#@testing pd <- get_parse_data(parse(text='a+b', keep.source = TRUE)) fb <- pd_get_firstborn(roots(pd), pd) expect_identical(token(fb), "'+'") expect_true(pd_is_firstborn(fb, pd)) expect_true(pd_is_firstborn(roots(pd), pd)) expect_false(pd_is_firstborn(next_sibling(fb), pd)) expect_true(fb %in% siblings(fb,pd)) expect_length(siblings(fb,pd), 3L) expect_equal(sum(pd_is_firstborn(siblings(fb,pd), pd)), 1L) } parsetools/R/pd_assign.R0000644000176200001440000001165513615112254014750 0ustar liggesusers#' @include internal.R assignment.opperators <- c( "LEFT_ASSIGN", "RIGHT_ASSIGN", "EQ_ASSIGN") #' @name assignments #' @title Assignment Node Navigation. #' @description #' These function help identify and navigate assignments in parse data. #' #' @details #' These functions only deal with assignment operators. #' Using [base::assign()] or [base::delayedAssign()] are considered #' calls in terms of parse data. #' #' There are five assignment operators grouped into three categories. #' #' * Left assignment, the [`<-`][base::assignOps] and [`<<-`][base::assignOps], #' * right assignment, [`->`][base::assignOps] and the rarely used [`->>`][base::assignOps] #' * and the equals assignment [`=`][base::assignOps]. #' #' @inheritParams pd_get_children_ids #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-assign.R NULL #' @describeIn assignments Check if the node is an assignment expression. pd_is_assignment <- function( id, pd, .check=TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id)>1L) return(sapply(id, pd_is_assignment, pd=pd)) token(id) %in% c( 'expr', 'equal_assign') && any(token(children(id)) %in% assignment.opperators) } all_assignment_ids <- make_get_all(pd_is_assignment) is_assignment <- internal(pd_is_assignment) if(FALSE){#@testing pd1 <- get_parse_data(parse(text="x <- 1", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd1), pd=pd1)) pd2 <- get_parse_data(parse(text="x <<- 1", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd2), pd=pd2)) pd3 <- get_parse_data(parse(roots(pd), text="1 -> x", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd3), pd=pd3)) pd4 <- get_parse_data(parse(text="1 ->> x", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd4), pd=pd4)) pd5 <- get_parse_data(parse(text="x = 1", keep.source=TRUE)) expect_equal(sum(pd_is_assignment(pd5$id, pd5)), 1) if(R.version$major < 4) { expect_true(pd_is_assignment(roots(pd5), pd=pd5)) } else { expect_false(pd_is_assignment(roots(pd5), pd=pd5)) expect_true(pd_is_assignment(firstborn(roots(pd5), pd5), pd5), pd5) } } #' @describeIn assignments Get the id for the value portion of an assignment. pd_get_assign_value_id <- function( id, pd, .check = TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(pd_is_assignment(id, pd))) } if(length(id) > 1) sapply(id, pd_get_assign_value_id, pd=pd) #nocov child.ids <- children(id, pd, 1, FALSE) type <- pd[pd$id %in% child.ids & pd$token %in% assignment.opperators, 'token'] switch( type , RIGHT_ASSIGN = min(child.ids) , max(child.ids) ) } assign_value <- internal(pd_get_assign_value_id, all_assignment_ids(pd)) if(FALSE){#!@testing pd <- get_parse_data(parse(text="x<-1", keep.source=TRUE)) expect_equal(pd_get_assign_value_id(all_assignment_ids(pd), pd=pd), 5L) pd <- get_parse_data(parse(text="x=1", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="x<<-1", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="1->x", keep.source=TRUE)) expect_equal(pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1')) ) pd <- get_parse_data(parse(text="1->>x", keep.source=TRUE)) expect_equal( pd_get_assign_value_id(all_assignment_ids(pd), pd=pd) , parent(.find_text('1'))) } #' @describeIn assignments Get the variable of an assignment. pd_get_assign_variable_id <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(pd_is_assignment(id, pd))) } if(length(id) > 1) sapply(id, pd_get_assign_variable_id, pd=pd) #nocov child.ids <- children(id, pd, 1, FALSE) assign.pd <- pd[pd$id %in% child.ids & pd$token %in% assignment.opperators, ] switch( assign.pd$token , RIGHT_ASSIGN = max(child.ids) , min(setdiff(child.ids, assign.pd$id)) ) } assign_variable <- internal(pd_get_assign_variable_id, all_assignment_ids(pd)) if(F){#!@testthat pd <- get_parse_data(parse(text="hello_world <- function(){ print('hello world') } ", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd), pd=pd)) expect_equal( pd_get_assign_variable_id(roots(pd), pd=pd) , parent(.find_text("hello_world"))) } if(F){#@test right_assign pd <- get_parse_data(parse(text="'hello_world' -> hw", keep.source=TRUE)) expect_true(pd_is_assignment(roots(pd), pd)) expect_equal( pd_get_assign_variable_id(roots(pd), pd=pd) , parent(.find_text("hw"))) } parsetools/R/accessors.R0000644000176200001440000002213113643120644014760 0ustar liggesusers{####################################################################### # accessors.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/. # }####################################################################### #' @include internal.R #' @name internal #' @title Internal Functions #' @param pd the parse data. #' @param id the ID of the expression #' @param line a line number #' @description These functions are for internal use but are documented #' here for reference. NULL #@internal token <- function(id=pd$id, pd=get('pd', parent.frame())){ #' @describeIn internal Extract the token pd[match(id, pd$id), 'token'] } if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) expect_equal(token(), pd$token) ids <- pd$id[match(c('rnorm', 'x', '<-'), pd$text)] expect_equal( token(ids, pd) , c("SYMBOL_FUNCTION_CALL", "SYMBOL", "LEFT_ASSIGN")) } #@internal text <- function(id=pd$id, pd=get('pd', parent.frame())){ #' @describeIn internal Extract the text pd[match(id, pd$id), 'text'] } if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) text <- c('rnorm', 'x', '<-') ids <- pd$id[match(c('rnorm', 'x', '<-'), pd$text)] expect_equal(text(pd$id, pd), pd$text) expect_equal(text(ids), text) expect_equal(text(ids, pd), text) } #@internal nodes <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Extract only the specified node(s). pd[match(id, pd$id), ] } if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) expect_equal(nodes(pd$id, pd), pd) expect_equal(nodes(pd$id), pd) expect_equal(nodes(c(45,3, 58), pd), pd[c('45', '3', '58'), ]) } #@internal start_line <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Get the line the expression starts on. pd[match(id, pd$id), 'line1'] } #@internal start_col <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Get the column the expression starts on. pd[match(id, pd$id), 'col1'] } #@internal end_line <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Get the line the expression ends on. pd[match(id, pd$id), 'line2'] } #@internal end_col <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Get the column the expression ends on. pd[match(id, pd$id), 'col2'] } #@internal filename <- function(pd=get('pd', parent.frame())){ #' @describeIn internal Extract the filename if available, otherwise return "". src <- attr(pd, 'srcfile') if (!is.null(src)) src$filename else "" } if(FALSE){#@test pd <- get_parse_data(parse(text="1+1")) expect_identical(filename(pd), "") attr(pd, 'srcfile') <- NULL expect_identical(filename(pd), "") } #@internal lines <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Extract the lines of text. text <- utils::getParseText(pd, id) unlist(strsplit(text, '\n', fixed=TRUE)) } #@internal is_terminal <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal does id represent a terminal node. pd[match(id, pd$id), 'terminal'] } #@internal is_first_on_line <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal is an expression the first one on a line? c(T, utils::head(pd$line2, -1) != utils::tail(pd$line1, -1)) [match(id, pd$id)] } if(FALSE){#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_true (is_first_on_line(1)) expect_false(is_first_on_line(2)) pd <- get_parse_data(parse(text={ "function(x, y){ x+ y+ 1 } "}, keep.source=TRUE)) } #@internal is_last_on_line <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal Is expression the last terminal node on the line? if (!is_terminal(id, pd)) return(FALSE) max(pd[pd$line2 == end_line(id, pd), 'col2']) == end_col(id, pd) } if(FALSE){#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_false(is_last_on_line(1, pd)) expect_true(is_last_on_line(4, pd)) expect_false(is_last_on_line(6, pd)) } #@internal spans_multiple_lines <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal does the expression span multiple lines? start_line(id) != end_line(id) } if(FALSE){#@testing pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_true(spans_multiple_lines(1, pd)) expect_false(spans_multiple_lines(4, pd)) expect_true(spans_multiple_lines(pd_all_root_ids(pd), pd)) } #@internal terminal_ids_on_line <- function(line, pd=get('pd', parent.frame())){ #' @describeIn internal Get the ids on a given line that are terminal nodes. pd$id[pd$line1 <= line & pd$line2 >= line & pd$terminal] } if(F){#@testing pd <- get_parse_data(parse(text=" { {1 + 3} {2 + sin(pi)} } ", keep.source=TRUE)) expect_equal(terminal_ids_on_line(1), 1) expect_equal(text(terminal_ids_on_line(2)), c('{', '1', '+', '3', '}')) pd <- get_parse_data(parse(text="' ' -> a.multiline.string", keep.source=TRUE)) expect_equal(text(terminal_ids_on_line(1, pd)), "'\n\n'") expect_equal(terminal_ids_on_line(2, pd), 1) expect_equal(terminal_ids_on_line(4, pd), integer(0)) } #@internal ids_starting_on_line <- function(line, pd=get('pd', parent.frame())){ #' @describeIn internal Get ids for nodes that start on the given line pd$id[pd$line1 == line] } #@internal ids_ending_on_line <- function(line, pd=get('pd', parent.frame())){ #' @describeIn internal Get ids for nodes that end on the given line pd$id[pd$line2 == line] } if(FALSE){#@testing pd <- get_parse_data(parse(text={"((1+ 2)+ 3)+ 4"}, keep.source=TRUE)) expect_identical(ids_starting_on_line(1), head(pd$id, 10)) expect_identical(ids_starting_on_line(4), tail(pd$id, 2)) expect_identical(ids_ending_on_line(1), 1:5) expect_identical(ids_ending_on_line(4), c(26L, 23L, 24L)) } #@internal prev_terminal <- function(id=pd$id, pd=get('pd', parent.frame())){ #' @describeIn internal Get the id for the terminal expression that is immediately prior to the one given. if (length(id)>1) return (sapply(id, prev_terminal, pd=pd)) ix <- which( pd$line1 <= start_line(id) & pd$col1 < start_col(id) & pd$terminal ) if (!any(ix)) return (NA_integer_) pd$id[max(ix)] } if(FALSE){#@testing pd <- get_parse_data(parse(text=" rnorm( 10, 0, 3)", keep.source=TRUE)) ids <- pd$id[match(c('10', '(', 'rnorm'), pd$text)] id <- ids[[1]] expect_equal( prev_terminal(ids[[1]], pd), ids[[2]]) expect_equal( prev_terminal(ids[[2]], pd), ids[[3]]) expect_equal( prev_terminal(ids[[3]], pd), NA_integer_) expect_equal( prev_terminal(ids, pd=pd) , c(utils::tail(ids, -1), NA_integer_) ) } #@internal expr_text <- function(id, pd=get('pd', parent.frame())){ #' @describeIn internal #' If id represents an `expr` token reiterate on the firstborn. #' Throws an error if anything but an expression or text if found. if (length(id)>1L) return(sapply(id, expr_text, pd=pd)) while (token(id) == 'expr' && n_children(id) == 1L) id <- firstborn(id) if (token(id) != 'STR_CONST') col_error(id, "a string constant is expected.") unquote(text(id)) } if(FALSE){#@testing pd <- get_parse_data(parse(text=" signature(x='hello', y='world') ", keep.source=TRUE)) ids <- c( parent(.find_text("'hello'")) , parent(.find_text("'world'")) ) expect_identical(expr_text(ids, pd), c("hello", "world")) expect_error( expr_text(pd_all_root_ids(pd)) , ":2:9: a string constant is expected." ) } #' @rdname accessors #' @title Accessor functions #' #' @param pd the parse data. #' @param id the ID of the expression #' @description #' This collection of function can be used to easily access elements of #' the parse data information. #' #' @aliases pd_text pd_token pd_start_line pd_end_line pd_filename pd_start_col pd_end_col pd_text <- external(text) pd_token <- external(token) pd_start_line <- external(start_line) pd_end_line <- external(end_line) pd_filename <- external(filename) pd_start_col <- external(start_col) pd_end_col <- external(end_col) parsetools/R/find-utils.R0000644000176200001440000000021213325455475015057 0ustar liggesusers #@internal .find_text <- function(text, pd=get('pd', parent.frame())){ stopifnot(length(text)==1L) pd[pd$text == text, 'id'] } parsetools/R/root.R0000644000176200001440000002506513643121021013755 0ustar liggesusers# root.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/. # #_____________________________________________________________________# #' @name root #' @title Root IDs #' #' @description #' Root IDs constitute the id of a stand alone expression. #' That is one that is not contained inside of another call or expression. #' The one exception to this is code blocks denoted by curly braces #' that are not themselves part of another call or expression; #' these we call code groups. #' In definition, A root node is defined to be a node that either #' has no parent or whose parent is a grouping node. #' #' @details #' If `ignore.groups=TRUE` then groupings are ignored and root nodes within the #' group are interpreted as roots, otherwise nodes within a group are not #' interpreted as root. Groupings are always interpreted as root if the #' parent is 0 or if the parent is a group and also a root. #' #' @inheritParams pd_get_children_ids #' #' @aliases root root-nodes root-ids #' @seealso see \code{\link{pd_is_grouping}} for details on what a grouping is. #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R list() pd_is_root <- function( id, pd , ignore.groups = TRUE #< Ignore groups? see details. , .check=TRUE ){ #' @describeIn root Test if a node is a root node #' @param ignore.groups Should \link[=pd_is_grouping]{groupings} be ignored? if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1) return(sapply(id, pd_is_root, pd=pd, ignore.groups=ignore.groups)) if (!(id %in% pd$id)) stop("id not present in pd") if (pd[pd$id == id,'token'] != 'expr') return(FALSE) parent <- pd[pd$id == id,'parent'] if (parent == 0 ) return(TRUE) if (ignore.groups && pd_is_grouping(parent, pd)) return(TRUE) return(FALSE) } is_root <- internal(pd_is_root) if(FALSE){#@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) root <- pd$id[pd$parent==0] leaf <- pd$id[pd$parent!=0][1] expect_true (pd_is_root(root, pd)) expect_false(pd_is_root(leaf, pd)) expect_equal(sum(pd_is_root(pd$id, pd=pd)), 1) pd <- get_parse_data(parse(text={'{ x <- rnorm(10, mean=0, sd=1) y <- runif(10) plot(x,y) }'}, keep.source=TRUE)) group.root <- pd$id[pd$parent==0] roots <- children(group.root)[-1] leaf <- .find_text('0') expect_true(pd_is_root(group.root, pd), info="Grouping root") expect_true(pd_is_root(roots[[1]], pd), info="Root within grouping.") expect_equal(sum(pd_is_root(pd$id, pd=pd)), 4) expect_equal(sum(pd_is_root(c(group.root, roots), pd)), 4) expect_false(pd_is_root(leaf, pd)) expect_equal(sum(pd_is_root(pd$id, pd, ignore.groups=FALSE)), 1) expect_error(pd_is_root(0L, pd)) pd[pd$parent %in% c(0,group.root) & pd$token == 'expr', ] expect_false(pd_is_root(roots[[1]], pd, ignore.groups = FALSE)) expect_equal(pd_is_root(c(group.root, roots[[1]]), pd, ignore.groups = FALSE), c(TRUE, FALSE)) pd <- get_parse_data(parse(text={" # a comment outside the grouping {# A grouping #' An Roxygen Comment hw <- function(){ {# Another Grouping # but not a root since it is burried within a function 1+2 #< an expression that is not a root. } 3+4 #< also not a root } 4+5 #< this is a root expression } 6+7 #< a regular root expression "}, keep.source=TRUE)) id <- max(pd[pd$token =="'{'", 'parent']) expect_true(pd_is_root(id, pd, ignore.groups = TRUE)) id <- min(pd[pd$token =="'{'", 'parent']) expect_equal(get_family_pd(id, pd)[3,'text'], "# Another Grouping") ids <- pd[pd$token =="'{'", 'parent'] expect_equal(pd_is_root(ids, pd, ignore.groups = TRUE ), c(TRUE, FALSE, FALSE)) expect_equal(pd_is_root(ids, pd, ignore.groups = FALSE), c(TRUE, FALSE, FALSE)) pd <- get_parse_data(parse(text=" # a comment an_expression() ", keep.source=TRUE)) expect_false(pd_is_root(pd[1,'id'], pd)) } .excluded.root.tokens <- c("'{'", "'}'", comment.classes$class, "NORMAL_COMMENT") pd_all_root_ids <- function( pd #< parse data from `` , include.groups = TRUE #< Include groups as root nodes (T) #^ or descend into [groups][pd_is_grouping] for roots? ){ #' @describeIn root give all root ids in `pd` #' @param include.groups Include groups as root nodes (T) #' or descend into [groups][pd_is_grouping] for roots? roots <- pd[ !(abs(pd$parent) %in% pd$id ) & !( pd$token %in% .excluded.root.tokens) , 'id'] while (!include.groups && any(. <- pd_is_grouping(roots, pd))) { groups <- roots[.] sub.ids <- pd[ pd$parent %in% groups & !(pd$token %in% .excluded.root.tokens) , 'id'] roots <- sort(c(roots[!.], sub.ids)) } return(roots) } roots <- internal(pd_all_root_ids) if(FALSE){#@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) bases <- pd[pd$parent==0, 'id'] groups <- parent(.find_text('{')) expect_equal(pd_all_root_ids(pd, TRUE), bases) roots <- pd_all_root_ids(pd, FALSE) expected <- parent(.find_text('<-')) expect_equal(roots, expected) expect_equal(getParseText(pd, roots), c('a <- 1','b <- 2', 'c <- 3', 'd <- 4', 'e <- 5')) pd <- get_parse_data(parse(text=" # a comment an_expression() ", keep.source=TRUE)) expect_equal( pd_all_root_ids(pd), -pd[1,'parent']) pd <- utils::getParseData(parse(text={" {# grouped code # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } } {#Second Group 1+2 } # Comment 3 4+5 "}, keep.source=TRUE)) expect_equal(pd_all_root_ids(pd), pd[pd$parent==0, 'id']) } all_root_nodes <- function( pd #< parse data from `` , include.groups = TRUE #< descend into grouped code \code{\{\}}? ){ #' @title Find all root node from parse data #' @inheritParams pd_get_children_ids #' @param include.groups descend into grouped code \code{\{\}}? #' #' @description #' A root node in a file is a standalone expression, such as in #' source file a function definition. #' when discussing a subset it is any expression that does not have #' a parent in the subset. pd[pd$id %in% pd_all_root_ids(pd, include.groups=include.groups), ] #' @return \code{\link{parse-data}} with for the root nodes. } if(FALSE){#!@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) expect_equal(all_root_nodes(pd, TRUE)$id , c(7, 52, 63)) expect_equal(all_root_nodes(pd, TRUE)$line1, c(1, 2, 9)) expect_equal(all_root_nodes(pd, FALSE)$id , c(7, 19, 31, 47, 63)) expect_equal(all_root_nodes(pd, FALSE)$line1, c(1, 3, 5, 7, 9)) } #@internal ascend_to_root <- function( id = pd$id , pd = get('pd', parent.frame()) , ignore.groups=TRUE #< Ignore groups? see . , .check=TRUE ) { #' @describeIn root ascend from id to root if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, ascend_to_root, pd=pd, ignore.groups=ignore.groups)) while (TRUE) { if (is.na(id) || id == 0) return(0L) if (id < 0) id <- -id if (pd_is_root(id, pd, ignore.groups=ignore.groups)) return(id) id <- parent(id) } } if(FALSE){#@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) root <- roots(pd) expect_equal(ascend_to_root(id=root, pd), root) expect_equal(ascend_to_root(id=1 , pd), root) expect_identical(ascend_to_root(id=0, pd), 0L) pd <- get_parse_data(parse(text={" #' hello world hw <- function(){ #! title print('hello world!') } #' comment after "}, keep.source=TRUE)) root <- roots(pd) expect_equal(ascend_to_root(.find_text("#' hello world"), pd), root) expect_equal(ascend_to_root(pd$id, pd=pd), c(rep(root, nrow(pd)-1), 0L)) pd <- get_parse_data(parse(text={" { #' hello world hw <- function(){ #! title print('hello world!') } #' comment after }"}, keep.source=TRUE)) expect_false( ascend_to_root(.find_text('hw'), pd) %in% roots(pd)) expect_true( ascend_to_root(.find_text('hw'), pd) %in% roots(pd, FALSE)) expect_true(is_root(next_sibling(.find_text("#' hello world")))) } parsetools/R/children.R0000644000176200001440000002007613643120656014574 0ustar liggesusers{####################################################################### # chilren.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/. # }####################################################################### #' @include internal.R #' @name family-nodes #' @title Family-wise Node Identification and Navigation. #' #' @description #' Parse data is organized into a hierarchy of nodes. These functions provide #' simple ways to identify the nodes of interest, often from a specified node #' of interest. #' #' @details #' The language parsetools uses is that of family. #' Similar to a family each node could have: a \dfn{parent}, the node that contains the #' node in question; \dfn{children}, the nodes contained by the given node; #' \dfn{ancestors}, the collection of nodes that contain the given node, it's parent, #' it's parent's parent, and so on; and \dfn{descendents}, the collection of nodes that are #' contained by the given node or contained by those nodes, and so on. #' Terminology is analogous, a \dfn{generation} is all the the nodes at the same depth in #' the hierarchy. A node may have \dfn{siblings}, the set of nodes with the same parent. #' If a node does not have a parent it is called a \dfn{root} node. #' #' Similarly, age is also used as an analogy for ease of navigation. Generally, nodes #' are numbered by the order that they are encountered, when parsing the source. #' Therefore the node with the smallest `id` among a set of siblings is referred to the #' \dfn{firstborn}. This is give the special designation as it is the most often of children #' used, as it likely determines the type of call or expression that is represented by the node. #' The firstborn has no 'older' siblings, the 'next' sibling would be the next oldest, i.e. the #' node among siblings with the smallest id, but is not smaller that the reference node id. #' #' In all cases when describing function the `id`, is assumed to be in the context of the #' parse data object `pd` and for convenience refers to the node associated with said `id`. #' #' @param pd The \code{\link{parse-data}} information #' @param id id of the expression of interest #' @param ngenerations Number of generations to go forwards or backwards. #' @param include.self Should the root node (\code{id}) be included? #' @param aggregate Should aggregate(TRUE) or only the #' the final (FALSE) generation be returned? #' @param .check Perform checks for input validation? #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-children.R NULL #' @describeIn family-nodes Get all nodes that are children of `id`. #' Get all ids in `pd` that are children of \code{id}. #' i.e. lower in the hierarchy or with id as a parent. #' If \code{ngenerations} is greater than 1 and \code{aggregate} #' is \code{TRUE}, all descendents are aggregated and returned. pd_get_children_ids <- function( id, pd , ngenerations = 1 , include.self = FALSE , aggregate = TRUE , .check=TRUE ) { if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } parents <- id ids <- if(include.self) parents else integer(0) while(ngenerations != 0) { ngenerations <- ngenerations - 1 old.ids <- ids new.ids <- pd[pd$parent %in% parents, 'id'] parents <- ids <- unique(c(if(aggregate)ids , new.ids)) if (identical(ids, old.ids)) break } ids } children <- internal(pd_get_children_ids) if(FALSE){#! @test pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) id <- pd[pd$parent==0, 'id'] kids <- pd[pd$parent==id, 'id'] expect_equal( pd_get_children_ids(id, pd, 1, include.self = FALSE) , kids , info="for default values" ) expect_equal( pd_get_children_ids(id, pd, 1, include.self=TRUE) , c(id,kids) , info='include.self=TRUE' ) grandkids <- pd[pd$parent %in% kids, 'id'] expect_equal( pd_get_children_ids( id, pd, 2, include.self=FALSE , aggregate = FALSE ) , grandkids , info='ngenerations=2, include.self=FALSE, aggregate=FALSE' ) expect_equal( sort(pd_get_children_ids( id, pd , ngenerations=2 , include.self=FALSE , aggregate = TRUE )) , sort(c(kids, grandkids)) , info='ngenerations=2, include.self=FALSE, aggregate=TRUE' ) expect_equal( sort(pd_get_children_ids( id, pd , ngenerations=2 , include.self=TRUE , aggregate = TRUE )) , sort(c(id, kids, grandkids)) , info='ngenerations=2, include.self=TRUE, aggregate=TRUE' ) expect_error( pd_get_children_ids(.Machine$integer.max, pd) , "id\\([0-9]+\\) is not present in given parse-data." ) expect_true( all(pd$id %in% pd_get_children_ids(0, pd, Inf))) } get_children_pd <- function( id, pd , ... #< passed to . , .check = TRUE ) { if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( length(id) == 1L , inherits(pd, 'parse-data') ) } pd[pd$id %in% children( id, pd,...), ] } if(FALSE){#!@test 'rnorm(10, mean=0, sd=1)' -> text pd <- get_parse_data(parse(text=text, keep.source=TRUE)) id <- pd[match('rnorm', pd$text), 'parent'] expect_identical( get_children_pd(id, pd), utils::head(pd, 1), info='defaults') expect_identical( get_children_pd(id, pd, include.self=TRUE), utils::head(pd, 2), info='include.self=TRUE') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=1, include.self=FALSE) , pd[pd$parent==parent(id),] , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=1, include.self=TRUE) , pd[pd$parent==parent(id) | pd$id==parent(id),] , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=2, include.self=TRUE) , pd , info='defaults') expect_identical( get_children_pd(id=parent(id), pd=pd, ngenerations=2, include.self=FALSE, aggregate=FALSE) , pd[pd$parent != parent(id) & pd$parent != 0, ] , info='defaults') expect_error(get_children_pd(id=pd$id, pd=pd)) } #' Count the number of children n_children <- function(id=pd$id, pd=get('pd', parent.frame())){ #' @inheritParams pd_get_children_ids if (length(id)>1L) return(sapply(id, n_children, pd=pd)) length(children(id)) } 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_equal(n_children(roots(pd)), c(3, 3, 8)) } parsetools/R/pd_function.R0000644000176200001440000002141213643121001015270 0ustar liggesusers{####################################################################### # pd_function.R # This file is part of the R package `parsetools`. # # Author: Andrew Redd # Copyright: 2017 University of Utah # # 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/. # }####################################################################### #' @name function-nodes #' @title Function Nodes #' @description #' These function help identify and navigate noses associated with #' function definition. #' #' @details #' A function node is the node for the expression that has as it's #' children the function keyword(firstborn), the arguments, including the #' nodes representing the opening closing parentheses in the definition, #' and finally a node, as the youngest, for the body of the function. #' #' @inheritParams pd_is_assignment #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-function.R NULL #' @describeIn function-nodes Test if the \code{id} points to a function. pd_is_function <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } !is.na(firstborn(id)) & token(firstborn(id)) == 'FUNCTION' } all_function_ids <- make_get_all(pd_is_function) is_function <- internal(pd_is_function) if(F){#! @testthat pd_is_function pd <- get_parse_data(parse(text="function(){}", keep.source=TRUE)) expect_true(pd_is_function(roots(pd), pd)) pd <- get_parse_data(parse(text="fun <- function(){}", keep.source=TRUE)) expect_false(pd_is_function(roots(pd), pd)) expect_length(all_function_ids(pd), 1L) } #' @describeIn function-nodes test if a node is contained in a function definition. pd_is_in_function <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id)>1L) return(sapply(id, pd_is_in_function, pd=pd, .check=FALSE)) any(is_function(ancestors(id))) } is_in_function <- internal(pd_is_in_function) if(FALSE){#@testing ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) id <- .find_text('"Congratulations!"') expect_true(pd_is_in_function(id, pd)) id <- .find_text('"myClass"') expect_identical(is_in_function(id), c(FALSE, FALSE)) } #' @describeIn function-nodes Obtain the body of a function pd_get_function_body_id <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(is_function(id, pd))) } if (length(id)>1L) return(sapply(id, pd_get_function_body_id, pd=pd)) max(children(id, pd)) } function_body <- internal(pd_get_function_body_id, all_function_ids(pd)) if(F){#@testing pd <- get_parse_data(parse(text="hello_world <- function(){ print('hello world') } ", keep.source=TRUE)) id <- all_function_ids(pd) expect_equal(pd_get_function_body_id(id, pd), parent(.find_text('{'))) pd <- get_parse_data(parse(text='function(l,r)paste(l,r)', keep.source=TRUE)) expect_identical( pd_get_function_body_id(all_function_ids(pd), pd=pd) , parent(parent(.find_text('paste')), pd) ) } if(FALSE){#@testing function_body vectorizing pd <- get_parse_data(parse(text=" hello_world <- function(){ print('hello world') } goodby_earth <- function(){ print('goodby earth') } ", keep.source=TRUE)) id <- all_function_ids(pd) expect_equal(pd_get_function_body_id(id, pd), parent(.find_text('{'))) } #' @describeIn function-nodes Obtain the ids for the arguments of a function pd_get_function_arg_ids <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( length(id) == 1L , pd_is_function(id, pd) ) } utils::tail(utils::head(children(id=id, pd=pd), -1), -1) } function_args <- internal(pd_get_function_arg_ids, all_function_ids(pd)) if(F){#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_function_ids(pd) expect_identical( text(pd_get_function_arg_ids(id, pd), pd=pd) , c('(', 'pd', '#< parse data', ',' , 'id', '=', '', '#< id number', ')' ) ) } #' @describeIn function-nodes Retrieve the variable for a function argument pd_get_function_arg_variable_ids <- function( id, pd, .check = TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( length(id) == 1L , pd_is_function(id, pd) ) } arg.ids <- function_args(id, pd) arg.ids[token(arg.ids, pd=pd) == 'SYMBOL_FORMALS'] } function_arg_variables <- internal(pd_get_function_arg_variable_ids, all_function_ids(pd)) if(F){#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- assign_value(all_assignment_ids(pd)) expected <- pd[pd$parent==id & pd$text %in% c('pd', 'id'), 'id'] expect_identical(pd_get_function_arg_variable_ids(id, pd), expected) expect_error(pd_get_function_arg_variable_ids(roots(pd), pd)) } #' @describeIn function-nodes Get the variable names for a function definition. pd_get_function_arg_variable_text <- function(id, pd, .check=TRUE){ text(pd_get_function_arg_variable_ids(id=id, pd=pd, .check=.check)) } if(FALSE){#@testing pd <- get_parse_data(parse(text=' function( a, b = 1){ cat("hello world") }', keep.source=TRUE)) id <- roots(pd) expect_identical( pd_get_function_arg_variable_text(id, pd) , c("a", "b") ) } #' @describeIn function-nodes is `id` a function argument? pd_is_function_arg <- function(id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } is_function(parent(id)) & ( token(id) %in% c('SYMBOL_FORMALS', 'EQ_FORMALS') | ( token(id) == 'expr' & !is.na(next_sibling(id)) & token(next_sibling(id)) != "'}'" & !is.na(prev_sibling(id)) & token(prev_sibling(id)) != "'{'" ) ) } is_function_arg <- internal(pd_is_function_arg) if(F){#@testing pd <- get_parse_data(parse(text=' function( a, b = 1){ cat("hello world") }', keep.source=TRUE)) id <- .find_text('a') expect_true(pd_is_function_arg(id, pd)) expect_false(pd_is_function_arg(.find_text('"hello world"'), pd)) expect_length(is_function_arg(pd$id, pd), nrow(pd)) expect_equal(sum(is_function_arg(pd$id, pd)), 4) } #' @describeIn function-nodes Retrieve relative documentation comments associated with function arguments. pd_get_function_arg_associated_comment_ids <- function( id, pd, .check = TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( length(id) == 1L , pd_is_function_arg(id, pd) ) } stopifnot(length(id)==1) sibling.args <- function_arg_variables(parent(id, pd), pd) all.siblings <- siblings(id, pd) comments <- intersect(all_relative_comment_ids(pd), all.siblings) comments[relative_comment_associateds(comments) == id] } function_arg_associated_comments <- internal(pd_get_function_arg_associated_comment_ids) if(F){#@testing pd <- get_parse_data(parse(text='pd_get_function_arg_ids <- function( pd #< parse data #< continuation comment , id = pd_all_root_ids(pd) ){}', keep.source=TRUE)) function.id <- assign_value(all_assignment_ids(pd), pd) arg.ids <- function_arg_variables(function.id, pd) id <- arg.ids[[1]] expect_identical(text(pd_get_function_arg_associated_comment_ids(id, pd), pd=pd) , c('#< parse data', '#< continuation comment')) expect_length(pd_get_function_arg_associated_comment_ids(arg.ids[[2]], pd), 0) } parsetools/R/family.R0000644000176200001440000001172613643120671014264 0ustar liggesusers# family.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/. # #_____________________________________________________________________# #' @include internal.R get_family_pd <- function( id, pd , include.self = TRUE , ngenerations = Inf , ... , include.doc.comments = TRUE , include.regular.comments = FALSE ){ #' @name get_family_pd #' @title Get family of nodes. #' @inheritParams pd_get_children_ids #' @param ... currently ignored. #' @param include.doc.comments include associated documentation comments. #' @param include.regular.comments include associated regular comments. #' @description #' Subset the \code{pd} to the family of \code{id}. id <- ._check_id(id) kids <- children(id, pd, include.self=include.self, ngenerations=ngenerations, ...) cids <- if (include.doc.comments || include.regular.comments){ if (!is_root(id, ignore.groups=FALSE) && is_grouping(parent(id))) { pd <- fix_grouping_comment_association(parent(id), pd, .check=FALSE) } pd[ pd$token %in% c( if (include.doc.comments ) comment.classes$class , if (include.regular.comments) 'NORMAL_COMMENT' ) & pd$parent == -id , 'id'] } pd[pd$id %in% c(kids, cids), ] #' @return a subset of the \code{\link{parse-data}} \code{pd}. } if(FALSE){#@testing pd <- get_parse_data(parse(text={"a <- 1 {# section 1 b <- 2 {# section 2 c <- 3 }# end of section 1 d <- 4 }# end of section 2 e <- 5 "}, keep.source=TRUE)) id <- ascend_to_root(pd[pd$text == 'c','id'], pd) expect_identical(get_family_pd(id, pd), pd[19:24,]) pd <- get_parse_data(parse(text={" # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } "}, keep.source=TRUE)) lid <- pd[match('LEFT_ASSIGN', pd$token), 'parent'] fam <- get_family_pd(lid, pd, include.doc.comments=TRUE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") fam <- get_family_pd(lid, pd, include.doc.comments=TRUE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "#' Documenation before") fam <- get_family_pd(lid, pd, include.doc.comments=FALSE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") fam <- get_family_pd(lid, pd, include.doc.comments=FALSE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "hw") pd <- get_parse_data(parse(text={" #demonstration of grouped code. { # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } }"}, keep.source=TRUE)) group.id <- roots(pd) expect_true(pd_is_grouping(group.id, pd)) id <- expr.id <- roots(pd, FALSE) fam <- get_family_pd(expr.id, pd, include.doc.comments=FALSE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], 'hw') fam <- get_family_pd(expr.id, pd, include.doc.comments=TRUE, include.regular.comments=FALSE) expect_equal(fam[1,'text'], "#' Documenation before") fam <- get_family_pd(expr.id, pd, include.doc.comments=TRUE, include.regular.comments=TRUE) expect_equal(fam[1,'text'], "# normal comment") } parsetools/R/errors.R0000644000176200001440000000224513373620425014315 0ustar liggesusers line_error <- function(id, msg, ..., pd=get('pd', parent.frame())) stop(filename(pd), ':', start_line(id, pd), ': ', msg, ...) line_error_if <- function(test, id, msg, ..., pd=get('pd', parent.frame())) if (force(test)) stop(filename(pd), ':', start_line(id, pd), ': ', msg, ...) col_error <- function(id, msg, ..., pd=get('pd', parent.frame())) stop(filename(pd), ':', start_line(id, pd), ':', start_col(id, pd), ': ', msg, ...) if(FALSE){#@testing errors pd <- get_parse_data(parse(text=' classDef <- setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) )', keep.source=TRUE)) id <- pd[pd$text == "#< the x field", 'id'] expect_error(line_error(id, 'testing', pd=pd) , ":3: testing") expect_error(line_error_if(TRUE, id, 'testing', pd=pd) , ":3: testing") expect_error( col_error(id, 'testing col error', pd=pd) , ":3:35: testing col error") expect_silent(line_error_if(FALSE, id, 'testing', pd=pd)) expect_null(line_error_if(FALSE, id, 'testing', pd=pd)) } parsetools/R/get_parse_data.R0000644000176200001440000004476313643120705015752 0ustar liggesusers# 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 `` 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 , 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") } parsetools/R/pd_if.R0000644000176200001440000001057613643121013014055 0ustar liggesusers{####################################################################### # pd_if.R # This file is part of the R package `parsetools`. # # Author: Andrew Redd # Copyright: 2017 University of Utah # # 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/. # }####################################################################### #' @name if-statements #' @title If Statement Nodes #' @description #' These function navigate logic statements. #' #' @details #' If statements have the form of the following. #' ``` #' if (predicate) branch else alternate #' ``` #' The `predicate` refers to the logical test being performed. #' The `branch` is the statement or block that is executed if `predicate` evaluates true. #' The `alternate` is the statement of block that is executed if `predicate` returns false. #' #' @inheritParams pd_get_children_ids #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-if.R NULL #' @describeIn if-statements Is node an if expression. pd_is_if <- function(id, pd, .check=TRUE){ if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id)>1) return(sapply(id, pd_is_if, pd=pd)) #nocov (token(id) == 'expr') && (token(firstborn(id)) == 'IF') } is_if <- internal(pd_is_if) all_if_ids <- make_get_all(pd_is_if) #' @describeIn if-statements Get the predicate node. pd_get_if_predicate_id <- function(id, pd, .check=TRUE){ #' @title Get if predicate id #' @inheritParams pd_is_if #' @description #' Returns the id of the predicate of the if statement, #' i.e. the conditional statement. if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(is_if(id,pd))) } kids <- children(id, pd) if (length(kids)<5) stop("inproper if statement") #nocov kids[[3L]] } if_predicate <- internal(pd_get_if_predicate_id, all_if_ids(pd)) #' @describeIn if-statements Get the `branch` statement or block node. pd_get_if_branch_id <- function(id, pd, .check=TRUE){ #' @title Get branch of if statement. #' @inheritParams pd_is_if #' @description #' Returns the id of the body of the branch executed if the predicate #' evaluates to true. if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(is_if(id,pd))) } kids <- children(id, pd) if (length(kids)<5) stop("inproper if statement") #nocov branch.id <- kids[[5L]] #TODO fix when a comment is in the way. #' @return an id integer. } if_branch <- internal(pd_get_if_branch_id, all_if_ids(pd)) #' @describeIn if-statements Get the `alternate` statement or block node. pd_get_if_alternate_id <- function(id, pd, .check=TRUE){ #' @title Get the alternate branch of if statement #' @inheritParams pd_is_if #' @description #' Gets the id of the alternate branch, i.e. the else branch. if (.check) { pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(is_if(id,pd))) } kids <- children(id, pd) if (length(kids)<7 || token(kids[[6]]) != 'ELSE') stop("inproper if-else statement") #nocov kids[[7L]] #' @return an id integer. } if_alternate <- internal(pd_get_if_alternate_id, all_if_ids(pd)) if(FALSE){#!@testing if structures pd <- get_parse_data(parse(text={" if(predicate){ body } else { alternate } "}, keep.source=TRUE)) id <- roots(pd) # 33 expect_true(pd_is_if(id,pd)) expect_equal(pd_get_if_predicate_id(id, pd), parent(.find_text('predicate'))) expect_equal(pd_get_if_branch_id (id, pd), parent(parent(.find_text('body')))) expect_equal(pd_get_if_alternate_id(id, pd), parent(parent(.find_text('alternate')))) } parsetools/R/iff_blocks.R0000644000176200001440000006177113643120722015106 0ustar liggesusers# iff_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/. # #_____________________________________________________________________# #@internal unquote <- function(x){ #! remove quotes from x #! @param x a [character] string. gsub("^('|\")(.*)\\1$", "\\2",x) } #' @name iff-blocks #' @title IFF Blocks #' @description #' IFF is short for `if(FALSE)\{#@@tag ...` blocks. #' These block can contain development, testing, or example code #' that can be extracted into documentation or other files. #' #' @inheritParams pd_is_if #' @param allow.short if \code{if(F)} should be considered an IFF block. #' @param tag The tag to consider. #' @param doc.only Should comments be restricted to documentation style #' comments only? #' @param ... passed along. #' #' @details #' Here are some examples: #' #' * `if(FALSE)\{#' @test ...` Is valid and tags the block as a test. #' * `if(FALSE)\{#@test ...` Is valid and tags the block as a test. #' Note here that we are using the `#@@` tag #' comment. #' * `if(FALSE)\{# @test ...` Is valid only if `doc.only==FALSE`. #' * `if(FALSE)#@test ...` NULL pd_is_iff <- function( id, pd , allow.short=TRUE #< Should `F` be interpreted as FALSE. , .check=TRUE ){ #' @describeIn iff-blocks #' This function tests if an expression id is the root of an #' \code{if(FALSE)} statement, differs from `pd_is_iff_block` #' in that it will return TRUE even if the conditional statement #' is not a formal bracketed block `{...}`. if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id) } if (length(id) > 1) return(sapply(id, pd_is_iff, pd=pd, allow.short=allow.short)) if (token(id) != 'expr') return(FALSE) kids <- children(id, pd) if (length(kids) < 2) return(FALSE) if (!identical(pd[match(utils::head(kids, 2), pd$id), 'token'], c("IF", "'('"))) return(FALSE) grandkids <- children( kids[[3]], pd) row <- pd[match(grandkids, pd$id),] return( ( row[['token']] == "NUM_CONST" && row[['text']] == "FALSE") || allow.short && ( row[['token']] == "SYMBOL" && row[['text']] == "F") ) } is_iff <- internal(pd_is_iff, roots(pd)) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# not an if(F)block } if(FALSE) expect_true(TRUE) #< IFF but not a block "}, keep.source=TRUE)) expect_true (pd_is_iff(roots(pd)[[1]], pd)) expect_true (pd_is_iff(roots(pd)[[2]], pd)) expect_false(pd_is_iff(roots(pd)[[2]], pd, FALSE)) expect_false(pd_is_iff(roots(pd)[[3]], pd)) expect_true (pd_is_iff(roots(pd)[[4]], pd)) expect_equal(pd_is_iff(roots(pd), pd), c(TRUE, TRUE, FALSE, TRUE)) expect_equal( is_iff(pd=pd), c(TRUE, TRUE, FALSE, TRUE)) } pd_is_iff_block <- function( id, pd , allow.short=TRUE , .check=TRUE ){ #' @describeIn iff-blocks #' Tests if an expression id is the root of an #' \code{if(FALSE)} block statement, differs from `pd_is_iff` #' in that in addition to it being an `if(FALSE)` expression #' the conditional branch of the logic must be a braced block #' of code. E.g. if given the id corresponding to #' `if(FALSE){...}`, both `pd_is_iff()` and `pd_is_iff_block()` #' would return TRUE while for `if(FALSE)do_somthing()` #' `pd_is_iff()` would return TRUE but `pd_is_iff_block()` would #' return FALSE because the expression is not a 'block' statement. if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id) } if (length(id) > 1) return(sapply( id, pd_is_iff_block, pd=pd , allow.short=allow.short , .check=FALSE)) # nocov if (!is_iff(id=id, pd=pd, allow.short=allow.short)) return(FALSE) kids <- children(id, pd) (token(baby <- max(kids)) == 'expr') && (token(firstborn(baby)) == "'{'") } is_iff_block <- internal(pd_is_iff_block, roots(pd)) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# not an if(F)block } if(FALSE) expect_true(TRUE) #< IFF but not a block "}, keep.source=TRUE)) expect_true (pd_is_iff_block(roots(pd)[[1]], pd)) expect_true (pd_is_iff_block(roots(pd)[[2]], pd)) expect_false(pd_is_iff_block(roots(pd)[[2]], pd, FALSE)) expect_false(pd_is_iff_block(roots(pd)[[3]], pd)) expect_false(pd_is_iff_block(roots(pd)[[4]], pd)) expect_equal(pd_is_iff_block(roots(pd), pd), c(TRUE, TRUE, FALSE, FALSE)) expect_equal(pd_is_iff_block(roots(pd), pd, FALSE), c(TRUE, FALSE, FALSE, FALSE)) expect_equal( is_iff_block(pd=pd), c(TRUE, TRUE, FALSE, FALSE)) } #' @describeIn iff-blocks Get all ids corresponding to IFF expressions. pd_all_iff_ids <- make_get_all(is_iff) all_iff_ids <- internal(pd_all_iff_ids) #' @describeIn iff-blocks Get all ids corresponding to IFF block pd_all_iff_block_ids <- function( pd , root.only=TRUE #< only root blocks(`TRUE`) or all block (`FALSE`) , ignore.groups=FALSE #< Ignore code grouping , ... #< passed to ){ #' @param root.only only root blocks(`TRUE`) or all block (`FALSE`) #' @param ignore.groups Ignore code grouping pd <- ._check_parse_data(pd) id <- if (root.only) roots(pd, !ignore.groups) else pd$id if (!length(id)) return(integer(0)) is.iff <- pd_is_iff_block(id, pd, ...) id[is.iff] } all_iff_block_ids <- internal(pd_all_iff_block_ids) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" if(FALSE){# an if(FALSE) block } if(F){# also an if(FALSE) block } {# grouping block if(F){# iff nested in group } } hw <- function(){ if(F){# nested in a function } print('hello world') } "}, keep.source=TRUE)) iff.ids <- all_iff_block_ids(pd, root.only=TRUE, ignore.groups = FALSE) expect_equal(length(iff.ids), 2) iff.ids <- all_iff_block_ids(pd, root.only=TRUE, ignore.groups = TRUE) expect_equal(length(iff.ids), 3) iff.ids <- all_iff_block_ids(pd, root.only=FALSE, ignore.groups = FALSE) expect_equal(length(iff.ids), 4) } pd_is_tagged_iff_block <- function( id, pd, tag , doc.only = TRUE , ... , .check=TRUE ){ #' @describeIn iff-blocks Test if a block if both an IFF block statement and is tagged. #' To tag an IFF block the first pared element must be a comment that contains #' an '@' tag to denote a special block. The comment on the same line as the #' opening brace or on any subsequent line but cannot be preceded by any other #' statement. if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1) return(sapply(id, pd_is_tagged_iff_block, pd=pd, tag=tag, doc.only=doc.only)) if (!pd_is_iff_block(id, pd) || token(. <- if_branch(id)) != 'expr' || token(. <- firstborn( . , pd)) != "'{'" ||!is_comment(. <- next_sibling(.)) ) return(FALSE) if (doc.only && !is_doc_comment(.)) return(FALSE) return(pd_has_tag(., pd, tag)) } if(FALSE){#!@testing pd <- get_parse_data(parse(text={" if(FALSE){#!@tag } if(F){#@tag } if(F){# @tag } {#!@tag # not an if(F) block } {#@tag } {# @tag } if(FALSE)#@tag not valid FALSE "}, keep.source=TRUE)) tag <- 'tag' id <- roots(pd) expect_equal(length(id), 7) expect_true (pd_is_tagged_iff_block(id[[1]], pd, tag)) expect_true (pd_is_tagged_iff_block(id[[3]], pd, tag, FALSE)) expect_false(pd_is_tagged_iff_block(id[[3]], pd, tag, TRUE )) expect_false(pd_is_tagged_iff_block(id[[6]], pd, tag)) expect_false(pd_is_tagged_iff_block(id[[7]], pd, tag)) expect_equal(pd_is_tagged_iff_block(id, pd, tag) , c(T,T,F,F,F,F,F)) expect_equal(pd_is_tagged_iff_block(id, pd, tag, FALSE) , c(T,T,T,F,F,F,F)) pd <- get_parse_data(parse(text='rnorm(1)', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F)#!@tag not in block\nF', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){FALSE}', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){# @tag\nF\n}', keep.source=TRUE)) expect_false(pd_is_tagged_iff_block(roots(pd), pd, tag)) pd <- get_parse_data(parse(text='if(F){#@tag\nF\n}', keep.source=TRUE)) expect_true(pd_is_tagged_iff_block(roots(pd), pd, tag)) } pd_all_tagged_iff_block_ids <- function(pd, tag, doc.only=TRUE){ #' @title Find all tagged \code{if(FALSE)} blocks. #' @inheritParams pd_is_iff #' @description #' Retrieves all ids identifying \code{\link[=iff-blocks]{if(FALSE)}} #' blocks that are also tagged with \code{tag}. #' See \code{\link{pd_is_tagged_iff_block}} for details. #' #' @seealso \code{\link{pd_is_iff_block}}, \code{\link{pd_is_tagged_iff_block}}, #' \code{\link{pd_has_tag}} #' @return an integer vector giving the ids in \code{pd} that identify #' \code{\link[=iff-blocks]{if(FALSE)}}\link[=iff-blocks]{ blocks} #' that are also tagged with \code{tag}. id <- all_iff_block_ids(pd) if (!length(id)) return(id) is.tagged <- pd_is_tagged_iff_block(id=id, tag=tag, pd=pd, doc.only=doc.only) id[is.tagged] } all_tagged_iff_block_ids <- internal(pd_all_tagged_iff_block_ids) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" if(FALSE){#!@tag # yes } if(F){#@tag # yes } if(F){# @tag # determines doc.only parameter } {#!@tag # not an if(F) block } {#@tag # no } {# @tag # no } "}, keep.source=TRUE)) tag <- 'tag' id <- roots(pd) tagged.iff.ids <- all_tagged_iff_block_ids(pd, tag) pd <- get_parse_data(parse(text={" # this has no iff blocks "}, keep.source=TRUE)) tag <- 'tag' tagged.iff.ids <- all_tagged_iff_block_ids(pd, tag) expect_identical(tagged.iff.ids, integer(0)) } pd_get_iff_associated_name_id <- function(id, pd, .check=TRUE){ #' @title Find the name that should be associated with an \code{if(FALSE)} block. #' @inheritParams pd_is_iff_block #' #' @description #' For \code{\link[=iff-blocks]{if(FALSE)}} documentation blocks, such as #' \code{@testing} and \code{@example} blocks, a user may supply an #' information string which gives the name information for tests and #' examples. for example, in `if(FALSE)\{#@@test my special test` # } #' the information string is "my special test". #' #' The more common case is when there is no information string. #' In these cases the name is inferred by the previous assignment or #' declaration. #' #' The \code{id} argument should identify one and only one #' \code{\link[=iff-blocks]{if(FALSE)}} block, but as this is an internal #' function, argument checks are not performed. #' #' @details if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(pd_is_iff_block(id, pd))) } if (length(id)>1L) return(sapply(id, pd_get_iff_associated_name_id, pd=pd, .check=FALSE)) prev.id <- prev_sibling(id, pd) while (TRUE){ #' IFF blocks can be placed #' sequentially and \code{pd_get_iff_associated_name_id} will #' navigate back until it finds a non-IFF block to use for the name. #' This way users can place multiple tests and examples after a #' declaration. #' if (is.na(prev.id)) return(NULL) if (!pd_is_iff_block(prev.id, pd)) break prev.id <- prev_sibling(prev.id, pd) } if (pd_is_assignment(prev.id, pd)) { #' If the previous expression is an assignment, the assignee variable of #' the assignment is chosen as the name. value.id <- assign_value(prev.id) structure( utils::getParseText(pd, assign_variable(prev.id)) , type = if (is_function(value.id)) "function_assignment" else "assignment" ) #' An attribute 'type' is also set on the return value. #' For function assignments \code{type="function_assignment"}, #' for all other assignments \code{type="assignment"}. #' } else if(is_symbol_call(prev.id,pd)) { switch( text(call_symbol(prev.id, pd)) , setClass = { #' The names for \code{link{setClass}} calls will also be inferred. #' The name of the class is taken as the name, but the #' return value also has the attribute of #' \code{type="setClass"}. #' Note that it is common to assign the result of #' \code{\link{setClass}} to a variable, which may or #' may not match the class name. In those cases the #' assignment operation takes priority and would have #' \code{type="assignment"}. #' args <- call_args(prev.id) line_error_if (length(args) == 0, prev.id, ": setClass must be called with a Class argument.") name <- { class.arg <- if ('Class' %in% names(args)) args[['Class']] else args[[1L]] while (token(class.arg) == 'expr') class.arg <- firstborn(class.arg) if (token(class.arg) == 'STR_CONST') unquote(text(class.arg)) else line_error(prev.id, 'Cannot infer Class argument of setClass.') } structure(name, type = "setClass") } , setMethod = { #' The names for \code{\link{setMethod}} will assume #' the S3 convention of \code{.}. args <- call_args(prev.id) line_error_if(length(args)==0, prev.id, "setMethod must be called with arguments.") fname <- { fname.arg <- args[[ifelse('f' %in% names(args), 'f', 1L)]] while (token(fname.arg) == 'expr') fname.arg <- firstborn(fname.arg) if (token(fname.arg) == 'STR_CONST') unquote(text(fname.arg)) else line_error(prev.id, "Cannot infer method name for setMethod.") } #' In the case the the signature is more than just the class, #' the signature will be collapsed, separated by commas. signature <- { # args[[ifelse('signature' %in% names(args), 'signature', 2L)]] sig.arg <- args[[ifelse('signature' %in% names(args), 'signature', 2L)]] if ( is_symbol_call(sig.arg,pd) && (text(call_symbol(sig.arg)) %in% c('signature', 'c')) ) { expr_text(call_args(sig.arg)) } else if (token(firstborn(sig.arg)) == 'STR_CONST'){ expr_text(sig.arg) } else line_error(sig.arg, 'Cannot infer signature for setMethod.') } name <- paste0(fname, paste0(',', signature, collapse=''), '-method') structure(name, type="setMethod") #' the type attribute will be set to \code{"setMethod"}. #' } , setGeneric = { #' \code{\link{setGeneric}} can also be used with the name #' of the generic function the inferred name and #' \code{type="setGeneric"}. args <- call_args(prev.id) line_error_if(length(args)==0, prev.id, "setGeneric must be called with arguments.") fname <- { fname.arg <- args[[ifelse('f' %in% names(args), 'f', 1L)]] while (token(fname.arg) == 'expr') fname.arg <- firstborn(fname.arg) if (token(fname.arg) == 'STR_CONST') unquote(text(fname.arg)) else line_error(prev.id, "Cannot infer method name for setGeneric.") } structure(fname, type='setGeneric') } , setAs = {#coerce,call,usage #' \code{\link{setAs}} infers coerce methods. #' \code{type="setAs"}. args <- call_args(prev.id) line_error_if(length(args) < 2, prev.id, "setAs must be called with arguments.") fname <- 'coerce' from <- { fname.arg <- args[[ifelse('from' %in% names(args), 'from', 1L)]] while (token(fname.arg) == 'expr') fname.arg <- firstborn(fname.arg) if (token(fname.arg) == 'STR_CONST') unquote(text(fname.arg)) else line_error(prev.id, "Cannot infer from class for setAs.") } to <- { fname.arg <- args[[ifelse('to' %in% names(args), 'to', 2L)]] while (token(fname.arg) == 'expr') fname.arg <- firstborn(fname.arg) if (token(fname.arg) == 'STR_CONST') unquote(text(fname.arg)) else line_error(prev.id, "Cannot infer to argument for setAs.") } structure( paste0(paste(fname, from, to, sep=','), '-method') , from=from, to=to, type='setAs') } , NULL#' if not specified above the function returns \code{\link{NULL}}. ) } } iff_associated_name <- internal(pd_get_iff_associated_name_id, all_iff_block_ids(pd)) 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 } setMethod("fun", c("A","B"), function(x,y){ x+y }) if(F){#!@testing #testing a setMethod with multiple signature elements. } 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_null( pd_get_iff_associated_name_id(iff.ids[[1L]], pd), info="iff at beginning") expect_equal( pd_get_iff_associated_name_id(iff.ids[[2L]], pd) , structure("hello_world", type = "function_assignment") , info="iff after function assignment") expect_equal( pd_get_iff_associated_name_id(iff.ids[[3L]], pd) , structure("ldf", type = "assignment") , info="iff after other assignment") expect_equal( pd_get_iff_associated_name_id(iff.ids[[4L]], pd) , structure("f2", type = "function_assignment") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[5L]], pd) , structure("A", type = "setClass") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[6L]], pd) , structure("print,A-method", type = "setMethod") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[7L]], pd) , structure("my_generic", type = "setGeneric") , info="iff after other iff") expect_null ( pd_get_iff_associated_name_id(iff.ids[[8L]], pd) , info="following call") expect_equal( pd_get_iff_associated_name_id(iff.ids[[9L]], pd) , structure("fun,A,B-method", type = "setMethod") , info="iff after other iff") expect_equal( pd_get_iff_associated_name_id(iff.ids[[10L]], pd) , structure("coerce,class1,class2-method", type = "setAs" , from='class1', to='class2' ) , info="setAs") } if(FALSE){#@testing iff_associated_name errors pd <- get_parse_data(parse(text={' setClass(A) if(F){#@testing #testing a setClass }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(pd) , "Cannot infer Class argument of setClass") pd <- get_parse_data(parse(text={' setMethod(A, "class") if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(pd) , "Cannot infer method name for setMethod.") pd <- get_parse_data(parse(text={' setMethod("show", setClass("A")) if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer signature for setMethod.") pd <- get_parse_data(parse(text={' setMethod("show", A) if(F){#@testing #testing a setMethod }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer signature for setMethod.") pd <- get_parse_data(parse(text={' setGeneric(generic, function(x){x}) if(F){#@testing #testing a setGeneric }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer method name for setGeneric.") pd <- get_parse_data(parse(text={' setAs(from, "to") if(F){#@testing #testing a setAs }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer from class for setAs.") pd <- get_parse_data(parse(text={' setAs("from", to) if(F){#@testing #testing a setAs }'})) id <- all_tagged_iff_block_ids(pd, c('testing', 'testthat', 'test')) expect_error( iff_associated_name(id, pd) , "Cannot infer to argument for setAs.") } parsetools/R/pd_comments.R0000644000176200001440000000756713374620460015325 0ustar liggesusers #' Associate relative documentation comments #' #' Relative comment created with \code{\#\<} comment tags document something #' designated by the location of the comment. #' In general, the comment documents the previous symbol. #' A comment will not be associated with any parse id that does not have #' the same parent as the comment. For example, #' #' function(x #< a valid comment #' ){} #' #' would associate \code{a valid comment} with \code{x}, but #' #' function(x){ #< not a valid comment #' } #' #' would not. #' #' @return Returns a vector of the same length as id. Where the value is #' either the id of the associated object or NA if it cannot be #' associated. pd_get_relative_comment_associated_ids <- function( id, pd, .check=TRUE){ #' @inheritParams pd_get_children_ids if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( all(pd_is_relative_comment(id, pd))) } if (length(id)>1L) return(sapply(id, pd_get_relative_comment_associated_ids, pd=pd)) sibs <- siblings(id, pd) possible <- sibs[token(sibs, pd) == 'SYMBOL_FORMALS'] if (length(possible) == 0L) return(NA) possible <- possible[end_line(possible) <= start_line(id)] if (length(possible)==1L) return(possible) if (length(possible) == 0L) return(NA) possible <- possible[end_line(possible) == max(end_line(possible))] possible <- possible[end_col(possible) == max(end_col(possible))] stopifnot(length(possible) == 1) return(possible) } relative_comment_associateds <- internal(pd_get_relative_comment_associated_ids) if(FALSE){#@test function relative comments pd <- get_parse_data(parse(text='function( pd #< parse data #< continuation comment , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) value <- pd_get_relative_comment_associated_ids(id, pd) expect_identical(value[[1]], value[[2]]) expect_identical(text(value, pd=pd), c('pd', 'pd', 'id')) # while one argument documented and another not should be discouraged, # it is allowed. pd <- get_parse_data(parse(text='function( id, pd = get("pd", parent.frame()) #< parse data ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) expect_identical(text(pd_get_relative_comment_associated_ids(id, pd), pd=pd), 'pd') pd <- get_parse_data(parse(text='function( id, #< traditional comma placement. pd = get("pd", parent.frame()) #< parse data ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd) value <- pd_get_relative_comment_associated_ids(id, pd) expected <- pd[ token(pd$id, pd=pd) == "SYMBOL_FORMALS" & text(pd$id, pd=pd) %in% c("pd", "id") , 'id'] expect_identical(value, expected) } if(FALSE){#@test class members pd <- get_parse_data(parse(text=' classDef <- setClass( "testClass" , slots = c( x="numeric" #< the x field , y="matrix" #< the y field ) )', keep.source=TRUE)) ids <- all_relative_comment_ids(pd) id <- ids[[1]] expect_true(pd_is_in_class_definition(id,pd)) expect_identical( pd_is_in_class_definition(ids,pd), c(TRUE, TRUE)) expect_false(pd_is_in_class_definition(.find_text('classDef',pd), pd)) } if(FALSE){#@test no possible relative. pd <- get_parse_data(parse(text=' #< not a valid relative comment. function( #< also not valid pd #< continuation comment , id = pd_all_root_ids(pd) #< id number ){}', keep.source=TRUE)) id <- all_relative_comment_ids(pd)[[1]] expect_true(is.na(pd_get_relative_comment_associated_ids(id, pd))) id <- all_relative_comment_ids(pd)[[2]] expect_true(is.na(pd_get_relative_comment_associated_ids(id, pd))) } parsetools/R/comments.R0000644000176200001440000002533513643120664014633 0ustar liggesusers{####################################################################### # comments.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/. # }####################################################################### #@internal comment.classes <- data.frame( prefix = c( "#'" , "#!" , "#<" , "#^" , "#@" ) , class = c( "ROXYGEN_COMMENT", "DOC_COMMENT", "RELATIVE_COMMENT", "CONTINUATION_COMMENT", "TAG_COMMENT") , stringsAsFactors = FALSE ) classify_comment.character <- function(x){ stopifnot(is.character(x)) lead <- substring(x, 1, 2) ifelse( nchar(x) > 0 , ifelse( substring(x, 1, 1) == "#" , ifelse( lead == comment.classes[1, 1], comment.classes[1, 2] , ifelse( lead == comment.classes[2, 1], comment.classes[2, 2] , ifelse( lead == comment.classes[3, 1], comment.classes[3, 2] , ifelse( lead == comment.classes[4, 1], comment.classes[4, 2] , ifelse( lead == comment.classes[5, 1], comment.classes[5, 2] , "NORMAL_COMMENT" ))))) , "") , "") } if(FALSE){#@testing expect_equal(classify_comment.character("## normal comment "), "NORMAL_COMMENT") expect_equal(classify_comment.character("#' Roxygen comment "), "ROXYGEN_COMMENT") expect_equal(classify_comment.character("#! Documentation comment"), "DOC_COMMENT") expect_equal(classify_comment.character("#< Relative comment "), "RELATIVE_COMMENT") expect_equal(classify_comment.character("#^ Continuation comment "), "CONTINUATION_COMMENT") expect_equal(classify_comment.character("#@ Tag comment "), "TAG_COMMENT") expect_equal(classify_comment.character("1"), "") } classify_comment.data.frame <- function(x){ stopifnot(valid_parse_data(x)) idx <- x$token == "COMMENT" x[idx, "token"] <- classify_comment.character(x[idx, "text"]) structure(x, class=c("parse-data", "data.frame")) } if(FALSE){#@testing x <- df <- utils::getParseData(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) pd <- classify_comment.data.frame(df) expect_is(pd, 'data.frame') expect_is(pd, 'parse-data') expect_equal( pd$token , c( "expr", "'{'" , "NORMAL_COMMENT", "ROXYGEN_COMMENT", "DOC_COMMENT" , "RELATIVE_COMMENT", "CONTINUATION_COMMENT", "TAG_COMMENT" , "'}'") ) } classify_comment <- function(x)UseMethod("classify_comment") if(FALSE){#@testing df <- utils::getParseData(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) pd <- classify_comment(df) comments <- nodes(all_comment_ids(pd)) expect_is(comments, 'data.frame') expect_is(comments, 'parse-data') expect_equal( comments$token , c( "NORMAL_COMMENT", "ROXYGEN_COMMENT", "DOC_COMMENT" , "RELATIVE_COMMENT", "CONTINUATION_COMMENT", "TAG_COMMENT" ) ) } #' @title Is this a comment? #' @description #' \subsection{pd_is_comment}{ #' Test if an id represents a comment of any kind. #' } #' @return Should return a logical vector, for parse-data and data.frame should #' be length of \code{nrow(x)}. For character same length as x. pd_is_comment <- function(id, pd, .check=TRUE){ #' @inheritParams pd_get_children_ids if (.check){# nocov start pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) }# nocov end token(id, pd) %in% c(comment.classes$class, "NORMAL_COMMENT") } all_comment_ids <- make_get_all(pd_is_comment) is_comment <- internal(pd_is_comment) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment Hello "}, keep.source=TRUE)) rtn <- is_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(T,T,T,T,T,T,F,F)) expect_equal( all_comment_ids(pd), (1:6)*3L) } #' @rdname pd_is_comment #' @description #' \subsection{pd_is_relative_comment}{ #' Tests if the comment is a relative (location dependent) type comment. #' } pd_is_relative_comment <- function(id, pd, .check=TRUE){ if(.check){# nocov start pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) }# nocov end token(id, pd) == "RELATIVE_COMMENT" } all_relative_comment_ids <- make_get_all(pd_is_relative_comment) #' @rdname pd_is_comment #' @description #' \subsection{pd_all_relative_comment_ids}{ #' Retrieve all ids associated with relative comments. #' } pd_all_relative_comment_ids <- external(all_relative_comment_ids) is_relative_comment <- internal(pd_is_relative_comment) if(F){#@testing pd <- get_parse_data(parse(text={" ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment Hello "}, keep.source=TRUE)) expect_is(rtn <- pd_is_relative_comment(pd$id, pd=pd), 'logical') expect_equal(rtn, c(F,F,F,T,F,F,F,F)) } #' @rdname pd_is_comment #' @description #' \subsection{pd_is_doc_comment}{ #' Additionally tests if the comment is a documentation type comment. #' } pd_is_doc_comment <- function(id, pd, .check=TRUE){ if (.check){# nocov start pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) }# nocov end token(id) %in% comment.classes$class } all_doc_comment_ids <- make_get_all(pd_is_doc_comment) is_doc_comment <- internal(pd_is_doc_comment) if(FALSE){#@testing pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) rtn <- is_doc_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(F,F,F,T,T,T,T,T,F)) pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) rtn <- is_doc_comment(pd$id, pd=pd) expect_is(rtn, 'logical') expect_equal(rtn, c(F,F,F,T,T,T,T,T,F)) } #' @export strip_doc_comment_leads.character <- function(comment, rm.space=TRUE){ comment <- gsub("^\\s+", "", comment) comment <- gsub("^#[!^<'{}@]", "", comment) if(rm.space) comment <- trimws(comment) comment } if(FALSE){#@testing expect_equal(strip_doc_comment_leads.character("# normal comment "), "# normal comment") expect_equal(strip_doc_comment_leads.character("#' Roxygen comment "), "Roxygen comment") expect_equal(strip_doc_comment_leads.character("#! Documentation comment"), "Documentation comment") expect_equal(strip_doc_comment_leads.character("#< Relative comment "), "Relative comment") expect_equal(strip_doc_comment_leads.character("#^ Continuation comment "), "Continuation comment") expect_equal(strip_doc_comment_leads.character("#@ Tag comment "), "Tag comment") } #' @export strip_doc_comment_leads.data.frame <- function(comment, rm.space=TRUE){ #@rdname strip_doc_comment_leads pd <- ._check_parse_data(comment) pd$text <- strip_doc_comment_leads.character(pd$text, rm.space=rm.space) pd } if(FALSE){#@testing pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) comments <- nodes(all_comment_ids(pd), pd) pd2 <- strip_doc_comment_leads.data.frame(comments) expect_is(pd2, 'data.frame') expect_is(pd2, 'parse-data') expect_equal( pd2$text , c( "## normal comment", "Roxygen comment" , "Documentation comment", "Relative comment" , "Continuation comment", "Tag comment" ) ) } #' @export #' @title Remove the characters identifying a documentation comment. #' @param comment The text of the comments or parse data. #' @param rm.space should the space at the beginning of the line be removed. #' @description #' Remove the characters identifying a documentation comment as a #' document comment leaving only the relevant text. strip_doc_comment_leads <- function( comment, rm.space = TRUE) UseMethod("strip_doc_comment_leads") if(FALSE){#@testing expect_equal(strip_doc_comment_leads("# normal comment "), "# normal comment") expect_equal(strip_doc_comment_leads("#' Roxygen comment "), "Roxygen comment") expect_equal(strip_doc_comment_leads("#! Documentation comment"), "Documentation comment") expect_equal(strip_doc_comment_leads("#< Relative comment "), "Relative comment") expect_equal(strip_doc_comment_leads("#^ Continuation comment "), "Continuation comment") expect_equal(strip_doc_comment_leads("#@ Tag comment "), "Tag comment") pd <- get_parse_data(parse(text="{ ## normal comment #' Roxygen comment #! Documentation comment #< Relative comment #^ Continuation comment #@ Tag comment }", keep.source=TRUE)) comments <- nodes(all_comment_ids(pd)) pd2 <- strip_doc_comment_leads(comments) expect_is(pd2, 'data.frame') expect_is(pd2, 'parse-data') expect_equal( pd2$text , c( "## normal comment", "Roxygen comment" , "Documentation comment", "Relative comment" , "Continuation comment", "Tag comment" ) ) } parsetools/R/pd_call.R0000644000176200001440000002004213643120737014373 0ustar liggesusers# pd_call.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/. # #_____________________________________________________________________# #' @include internal.R #' @name calls #' @title Call nodes #' @description #' Call nodes represent function calls. #' #' @details #' The traditional call of #' `function_name(arguments)` is a symbol call as `function_name` #' is the symbol directly referencing the function to call. #' Other calls may exists such as `function_array[[1]]()` which #' first indexes the `function_array` then calls the returned function. #' This qualifies as a call expression but not a symbol call expression. #' We are often only concerned with symbol calls and not the anonymous #' version. #' #' @inheritParams family-nodes #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-call.R NULL #' @describeIn calls Test if the node is a call expression. #' @param calls an optional list of calls to restrict consideration to. pd_is_call <- function( id, pd, calls = NULL, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id)>1) return(sapply(id, pd_is_call, pd=pd)) if (token(id) != 'expr') return(FALSE) fb <- firstborn(id) if (token(fb) == "'('") return(TRUE) if (token(fb) == "expr" && token(next_sibling(fb)) == "'('") return(TRUE) return(FALSE) } all_call_ids <- make_get_all(pd_is_call) is_call <- internal(pd_is_call) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_true (pd_is_call(ids[[3]], pd)) expect_false(pd_is_call(ids[[1]], pd)) expect_equal(pd_is_call(ids, pd), c(F, F, T)) } if(FALSE){#@test non-symbol calls text <- 'function_array[[1]](1)' text <- 'getAnywhere(rnorm)[1](1)' pd <- get_parse_data(parse(text=text, keep.source = TRUE)) id <- roots(pd) expect_true(pd_is_call(id, pd)) } #' @describeIn calls Test if the node is specifically a symbol call expression. pd_is_symbol_call <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1) return(sapply(id, pd_is_symbol_call, pd=pd)) if (!pd_is_call(id, pd)) return(FALSE) second <- next_sibling(firstborn(id, pd), pd) if (token(second) != "expr") return(FALSE) grandchild <- firstborn(second, pd) token(grandchild) == 'SYMBOL_FUNCTION_CALL' #' @return a logical of the same length as \code{id} } all_symbol_call_ids <- make_get_all(pd_is_symbol_call) is_symbol_call <- internal(pd_is_symbol_call) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_true (pd_is_symbol_call(id, pd)) expect_false(pd_is_symbol_call(ids[[1]], pd)) expect_equal(pd_is_symbol_call(ids, pd), c(F, F, T)) expect_false(pd_is_symbol_call(ids[[1]], pd)) } if(FALSE){#@test non-symbol call pd <- get_parse_data(parse(text={" (function()cat('hello world!'))() "}, keep.source=TRUE)) id <- roots(pd) expect_true(pd_is_call(id, pd)) expect_false(pd_is_symbol_call(id, pd)) } #' @describeIn calls Get the symbol, i.e. the name of the function, being called. pd_get_call_symbol_id <- function( id, pd, .check=TRUE){ if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(is_symbol_call(id,pd))) } if (length(id)>1) return(sapply(id, pd_get_call_symbol_id, pd=pd)) stopifnot(pd_is_symbol_call(id, pd)) children(next_sibling(firstborn(id))) } call_symbol <- internal(pd_get_call_symbol_id) if(FALSE){#!@testing pd <- get_parse_data(parse(text={" x <- rnorm(10, 0, 1) y <- runif(10) plot(x, y) "}, keep.source=TRUE)) ids <- roots(pd) id <- ids[[3]] expect_equal( pd_get_call_symbol_id(id, pd) , .find_text('plot')) } #' @describeIn calls test Get the set of arguments to the function call. pd_get_call_arg_ids <- function( id, pd, .check=TRUE){ #' @title get ids of the arguments of a call. #' @inheritParams pd_is_symbol_call #' @description #' Retrieves the ids of the arguments of a call as an integer vector. if(.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot( length(id)==1L , is_call(id,pd) ) } kids <- children(id, pd) ix <- text(kids) %in% c('(', ',', ')') if (all(ix[-1])) return(integer(0)) groups <- cumsum(ix) args <- sapply( split(kids, groups)[c(-1L, -max(groups)-1L)] , `[`, -1) val <- sapply( args, function(arg){ if (length(arg) == 1) return(arg) if (length(arg) == 2) { #! @note Are there cases other than [base::alist()] that could result in a two #! id argument? stopifnot( text(call_symbol(id)) == 'alist') return(NA_integer_) } if (length(arg) == 3) { stopifnot( all(token(arg) == c('SYMBOL_SUB', 'EQ_SUB', 'expr')) ) return(arg[[3]]) } stop("I don't know how to handle this :(") # nocov }) names(val) <- sapply(args, function(arg){ if (length(arg) == 1) return('') if (length(arg) > 1) return(text(arg[1])) }) return(val) #' @return a named list where each element is the id for the `expr` element of the argument. } call_args <- internal(pd_get_call_arg_ids, roots(pd)) if(FALSE){#! @testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) test.object <- pd_get_call_arg_ids(roots(pd), pd=pd) expect_is(test.object, 'integer') expect_equal(names(test.object), c('', 'mean', 'sd')) expect_identical( test.object , c( 5L , mean=parent(.find_text('0')) , sd =parent(.find_text('1'))) ) pd <- get_parse_data(parse(text='alist(x, y=z, ...=)', keep.source=TRUE)) expect_identical( call_args(all_call_ids(pd), pd=pd) , c( parent(.find_text('x')) , y = parent(.find_text('z')) , '...'=NA_integer_)) } parsetools/R/internal.R0000644000176200001440000001207713374621231014616 0ustar liggesusers#' Make a function operate internal to parsetools #' #' @param fun The function to make internal #' #' @description #' Convert a function to look for pd object in the `parent.frame()`, #' and the id to extract from the pd unless overwritten. internal <- function(fun, id=pd$id){ pd <- substitute(get('pd', parent.frame())) ..fun <- substitute(fun) ..id <- substitute(id) flist <- formals(fun) args <- list() if ('id' %in% names(flist)) args$id <- ..id if ('pd' %in% names(flist)) args$pd <- substitute(get('pd', parent.frame())) body.args <- lapply(names(args), as.name) names(body.args) <- names(args) if (length(setdiff(names(flist), c('id', 'pd', '.check')))){ args <- c(args, alist(...=)) body.args <- c(body.args, as.name('...')) } if ('.check' %in% names(flist)) body.args$.check = FALSE body <- as.call(c(..fun, body.args)) as.function( c(args, body) , envir = topenv() ) } if(F){#@testing external_test <- function(id, pd){"do something"} test <- internal(external_test) expected <- function(id=pd$id, pd=get('pd', parent.frame()))external_test(id=id, pd=pd) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) external_test2 <- function(id, pd, .check=TRUE){"do something"} test2 <- internal(external_test2) expected2 <- function(id=pd$id, pd=get('pd', parent.frame()))external_test2(id=id, pd=pd, .check=FALSE) environment(expected2) <- asNamespace('parsetools') expect_identical(test2, expected2) external_test3 <- function(id, pd, N=1){"do something"} test3 <- internal(external_test3) expected3 <- function(id=pd$id, pd=get('pd', parent.frame()), ...)external_test3(id=id, pd=pd, ...) environment(expected3) <- asNamespace('parsetools') expect_identical(test3, expected3) external_test4 <- function(id, pd, N=1, .check=TRUE){"do something"} test4 <- internal(external_test4) expected4 <- function(id=pd$id, pd=get('pd', parent.frame()), ...)external_test4(id=id, pd=pd, ..., .check=FALSE) environment(expected4) <- asNamespace('parsetools') expect_identical(test4, expected4) } make_get_all <- function(fun, id=pd$id){ ..fun <- substitute(fun) ..id <- substitute(id) flist <- formals(fun) args <- list() body.args <- list() if ('id' %in% names(flist)) body.args$id <- ..id if ('pd' %in% names(flist)){ body.args$pd <- as.name('pd') args$pd <- substitute(get('pd', parent.frame()), emptyenv()) } if (length(setdiff(names(flist), c('id', 'pd', '.check')))){ args <- c(args, alist(...=)) body.args <- c(body.args, as.name('...')) } if ('.check' %in% names(flist)) body.args$.check = FALSE ..call <- as.call(c(..fun, body.args)) body <- substitute(pd[..call, 'id'], list(..call=..call)) as.function( c(args, body) , envir = topenv() ) } if(FALSE){#@test pd_is_test <- function(id, pd, n=Inf, .check=TRUE){"do something"} test_all <- make_get_all(pd_is_test) expected <- function(pd=get('pd', parent.frame()),...)pd[pd_is_test(id=pd$id, pd=pd, ..., .check=FALSE), "id"] expect_equal(test_all, expected) } external <- function(fun){ ..fun <- substitute(fun) flist <- formals(fun) args <- list() if ('id' %in% names(flist)) args$id <- alist(id=)[[1]] if ('pd' %in% names(flist)) args$pd <- alist(pd=)[[1]] body.args <- lapply(names(args), as.name) names(body.args) <- names(args) if (length(setdiff(names(flist), c('id', 'pd', '.check')))){ args <- c(args, alist(...=)) body.args <- c(body.args, as.name('...')) } if ('.check' %in% names(flist)) body.args$.check = TRUE body <- as.call(c(..fun, body.args)) as.function( c(args, body) , envir = topenv() ) } if(F){#@testing internal_test <- function(id=pd$id, pd=get('pd', parent.frame())){"do something"} test <- external(internal_test) expected <- function(id, pd)internal_test(id=id, pd=pd) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), .check=FALSE){"do something"} test <- external(internal_test) expected <- function(id, pd)internal_test(id=id, pd=pd, .check=TRUE) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), N=1){"do something"} test <- external(internal_test) expected <- function(id, pd, ...)internal_test(id=id, pd=pd, ...) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) internal_test <- function(id=pd$id, pd=get('pd', parent.frame()), N=1, .check=FALSE){"do something"} test <- external(internal_test) expected <- function(id, pd, ...)internal_test(id=id, pd=pd, ..., .check=TRUE) environment(expected) <- asNamespace('parsetools') expect_identical(test, expected) } parsetools/R/siblings.R0000644000176200001440000001063513643121027014607 0ustar liggesusers# siblings.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/. # #_____________________________________________________________________# #' @include internal.R ## Siblings #### #' @title Navigate siblings #' @description #' These functions help to navigate siblings, nodes with the same parent. #' #' @inheritParams pd_get_children_ids #' @example inst/examples/example-pd.R #' @example inst/examples/example-roots.R #' @example inst/examples/example-function.R #' @example inst/examples/example-siblings.R NULL #' @describeIn family-nodes Identify siblings of `id`. pd_get_sibling_ids <- function(id, pd, .check=TRUE){ if (.check){# nocov start pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(length(id) == 1) }# nocov end children(parent(id, pd), pd) } siblings <- internal(pd_get_sibling_ids) #' @describeIn family-nodes Get the next younger sibling. pd_get_next_sibling_id <- function(id, pd, .check=TRUE){ if (.check){# nocov start pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) }# nocov end if (length(id) > 1L) return(sapply(id, pd_get_next_sibling_id, pd=pd, .check=FALSE)) sids <- siblings(id, pd) . <- which(sids>id) if (length(.)) min(sids[.]) else NA_integer_ } next_sibling <- internal(pd_get_next_sibling_id) if(FALSE){#@testing pd <- get_parse_data(parse(text='a+b', keep.source = TRUE)) id <- parent(.find_text('a')) expect_equal( pd_get_next_sibling_id(id,pd) , parent(.find_text('b')) ) expect_identical( pd_get_next_sibling_id(.find_text('a', pd), pd), NA_integer_) expect_identical( pd_get_next_sibling_id(.find_text('+', pd), pd) , parent(.find_text('a', pd)) ) expect_length(pd_get_next_sibling_id(pd$id, pd), nrow(pd)) expect_error(pd_get_next_sibling_id(1e9L, pd)) expect_error(pd_get_next_sibling_id(id, id)) } #' @describeIn family-nodes Get the next older sibling. pd_get_prev_sibling_id <- function(id, pd, .check=TRUE){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) } if (length(id) > 1L) return(sapply(id, pd_get_prev_sibling_id, pd=pd, .check=FALSE)) sibs <- siblings(id, pd) . <- which(sibs 1) return(sapply(id, pd_is_grouping, pd=pd, .check=FALSE)) #' @description #' A grouping is defined as a non empty set return( length(children(id)) #' starting with a curly brace token and && token(firstborn(id)) == "'{'" #' and for which there is no parent or the parent is also a grouping. && ( parent(id) == 0 || pd_is_grouping(parent(id), pd, .check=FALSE) ) ) #! @return a logical indicating if the root node(s) is a grouping node or not } is_grouping <- internal(pd_is_grouping) if(FALSE){#@testing pd <- get_parse_data(parse(text='{ this(is+a-grouping) }', keep.source=TRUE)) id <- pd[match("'{'", pd$token), 'id'] gid <- parent(id) expect_true (pd_is_grouping(gid, pd)) expect_false(pd_is_grouping( 1L, pd)) expect_is(pd_is_grouping(pd$id, pd=pd), 'logical') expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 1) expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 1L) pd <- get_parse_data(parse(text=' {# first Group {# nested group "expression in double nested group" } } ', keep.source=TRUE)) expect_equal(sum(pd_is_grouping(pd$id, pd=pd)), 2) } #' @title get the grouping ids #' @inheritParams pd_get_children_ids #' @description get the ids that represent the grouping nodes. #' @return an integer vector of ids. all_grouping_ids <- make_get_all(pd_is_grouping) if(FALSE){#@testing pd <- get_parse_data(parse(text='{ this(is+a-grouping) }', keep.source=TRUE)) expect_is(all_grouping_ids(pd), 'integer') expect_equal(length(all_grouping_ids(pd)), 1) expect_equal(all_grouping_ids(pd), pd[match("'{'", pd$token), 'parent']) } fix_grouping_comment_association <- function( id = all_grouping_ids(pd) , pd = get('pd', parent.frame()) , .check=TRUE ){ if (.check){ pd <- ._check_parse_data(pd) id <- ._check_id(id, pd) stopifnot(all(pd_is_grouping(id, pd))) } for (i in id) { cids <- children(i, pd) for (cid in cids) if (is_comment(cid, pd)) { n <- next_sibling(cid) while (!is.na(n) && (is_comment(n,pd) || token(n) == "'}'")) n <- next_sibling(n) if (!is.na(n)) { if (is_root(n, pd)) pd[ pd$id == cid, 'parent'] <- -n else pd[ pd$id == cid, 'parent'] <- -ascend_to_root(n, pd) # nocov } } } return(pd) } if(FALSE){#@testing pd <- get_parse_data(parse(text={" {# grouped code # normal comment #' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } } {# Second Group 1+2 } # Comment 3 4+5 "}, keep.source=TRUE)) ids <- all_grouping_ids(pd) fixed <- fix_grouping_comment_association(ids, pd) expect_identical( -parent(.find_text("#' Documenation before", fixed), fixed) , parent(.find_text('<-')) ) expect_identical(fixed[-6], pd[-6]) text(all_comment_ids(fixed), fixed) x <- pd_get_ancestor_ids(.find_text('print', fixed), fixed) inside.parent <- max(x[is_in_function(x, fixed) & ! is_function(x)]) expect_equal( abs(parent(all_comment_ids(fixed), fixed)) , c( rep(ascend_to_root(.find_text('hw', fixed), fixed), 3) , inside.parent , parent(.find_text('+')) ) ) } if(FALSE){#@test fix_grouping_comment_association Special case pd <- get_parse_data(parse(text={" {#' Documenation before hw <- function(){ #! documentation comment inside. print('hello world') } }"}, keep.source=TRUE)) fixed <- fix_grouping_comment_association(roots(pd), pd) expect_equal(nrow(pd), nrow(fixed)) expect_identical(pd$id, fixed$id) cid <- .find_text("#' Documenation before") expect_true( parent(cid, fixed) != parent(cid, pd)) expect_true(is_assignment(abs(parent(cid, fixed)), fixed)) expect_true(!any(is_comment(children(roots(fixed), fixed), fixed))) } parsetools/R/checks.R0000644000176200001440000000564013643120651014237 0ustar liggesusers{####################################################################### # checks.R # This file is part of the R package `parsetools`. # # Author: Andrew Redd # Copyright: 2017 University of Utah # # 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/. # }####################################################################### ._check_id <- function( id = get('id', parent.frame()) , pd = get('pd', parent.frame()) , present = TRUE #< check if the id is present in pd. ){ #! Verify and/or extract id is valid. if (is.numeric(id) && !is.integer(id)) id <- as.integer(id) if (!is.integer(id)) stop('id must be an object that can be coerced to an integer') if (present) { is.present <- id %in% pd$id if (!all(is.present | id == 0)) stop('id(', paste(id[!is.present], collapse=', '), ') is not present in given parse-data.') } return(invisible(id)) } if(FALSE){#!@testing pd <- get_parse_data(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) expect_error(._check_id(pd) , "id must be an object that can be coerced to an integer", info="Passing parse-data") expect_error(._check_id(iris), "id must be an object that can be coerced to an integer", info="data.frame but not parse-data") expect_identical(._check_id(1) , 1L , info="convert numeric to integer") expect_identical(._check_id(1.1), 1L , info="convert numeric to integer") expect_error(._check_id(TRUE) , info="passing logical that cannot be converted.") expect_error( ._check_id(1000, pd) , 'id\\(1000\\) is not present in given parse-data.' , info="passing logical that cannot be converted." ) } ._check_parse_data <- function(pd){ #! check_validity of parse_data if(inherits(pd, 'parse-data')) return(pd) else if(inherits(pd, 'data.frame')){ as_parse_data(pd) } else stop("Cannot convert to parse-data.") } if(FALSE){#!@testing df <- getParseData(parse(text='rnorm(10, mean=0, sd=1)', keep.source=TRUE)) pd <- ._check_parse_data(df) expect_is(pd, "parse-data") expect_error(._check_parse_data(NULL), "Cannot convert to parse-data.", info="passing NULL") expect_error(._check_parse_data(iris), "names of data do not conform", info="passing non-conforming data.frame") } parsetools/NEWS.md0000644000176200001440000000066613643121615013555 0ustar liggesusers# parsetools 0.1.3 * Updated individual file license boiler-plates to reflect the GPL-2 which is listed in the DESCRIPTION file. # parsetools 0.1.2 * Functionality updated to reflect change in parser introduced in revision 77722 of base R. # parsetools 0.1.1 * Bug fix for bug introduced in R-devel. * Internal fixes and enhancements. # parsetools 0.1 * Added a `NEWS.md` file to track changes to the package. * Initial Release. parsetools/MD50000644000176200001440000001411713643376012012766 0ustar liggesusersaa3135d86c23c5485faa7e150d121b5f *DESCRIPTION 8f69c76317a0f513a51804f3b0b792e9 *NAMESPACE 53e587f78e1cfc5c3cd8a09d6c02ea0c *NEWS.md f7ec96e5abb3d4df3670e82631cc5b71 *R/accessors.R 71040eb54b4d635c2f0c210e692c821f *R/checks.R 14e787175ef167b7428112cbc8239969 *R/children.R 8b01fa21a9f3809a195ff5a38402931d *R/comments.R 4d697739db63dc3ac50ba334cab38103 *R/errors.R 2c3a8e593a49ef3937092589aea159a5 *R/family.R 4c24a76cb25d261fedc90c48b0112ea0 *R/find-utils.R 035efd6a4929d384902d1ee131e68407 *R/firstborn.R 1f73233b0c07e2c72d30075d3b0fe82f *R/get_parse_data.R 99e8af79673c0c20d52d807c08908604 *R/grouping.R 14ac9dc102a901dd43d2b2588ad28f1d *R/iff_blocks.R 4bfe914794cb2f078b94d11c4d2bc034 *R/internal.R 6cff92a45de287952fd34165c8344920 *R/parent.R d05fecc32eb8dba06e1fce917666989d *R/pd_assign.R eec17a6c08826e43d7e2c323999ad0d9 *R/pd_call.R c428d6bf4bba4647f348f03fd8396d7f *R/pd_classes.R 9865c94af992c38ead900e56d1a31a0d *R/pd_comments.R b9e55e106daa68edec6ebe5f61972e19 *R/pd_function.R 42ce713bbb7ad6b54149b3ca84604ea4 *R/pd_identify.R e8455e0cac35b21db8c365172f0bee48 *R/pd_if.R c020a490ddd6e7242c126323daa4c2a6 *R/pd_make_is_in.R f19f73a6b5b61b2907329c1a70600cec *R/reconstitute.R 0322a5d048bf3b2b191be9e1dc1b5cb2 *R/root.R 76eac00637ff7da1bf0e99b6bb901a6c *R/siblings.R f48db8d9aca990bcf7a43cacca5db077 *R/tags.R 885500b1a5148fec193b6509c0b8a7d4 *R/testing_blocks.R b2981e214bac780c9dbfcccacbad5f20 *R/zzz.R 919950d40ce9fb0ce7f55f586f8d36c8 *build/vignette.rds 53f395e146bfa6587271f26e4eed65c3 *inst/WORDLIST ea8eab93de05207476b4c5f91642b478 *inst/doc/Coding_Conventions.R 07ec4fd1621c53c050e3717f5943a862 *inst/doc/Coding_Conventions.Rmd 4d7378900ae3b3828d0f4f8c6fe81ae3 *inst/doc/Coding_Conventions.html 8462aa2668d2fce6d30a81a74283e8a9 *inst/examples/example-assign.R e9123102580e9b46a8ad52b62ee68d37 *inst/examples/example-call.R 47e1262e2371d64fe0ad22318aa58f5c *inst/examples/example-children.R 975b741ee69a5ba5cd35bbb249f9f005 *inst/examples/example-classes.R 0e99598bdf47f222df2abab770def076 *inst/examples/example-function.R 98d7a03713cf910c8641cc7f83a76074 *inst/examples/example-get_parse_data.R 490061b1ab509e089f6205eef915c0b9 *inst/examples/example-if.R 5e77a005ff851dfb892921d1387a4610 *inst/examples/example-pd.R adc98d02be5e040883b9b81ba825e62d *inst/examples/example-reconstitute.R 3ae40a506017ba0f53967844ebf9c6bd *inst/examples/example-roots.R b3e732153ccd150c373d85e1df8daea2 *inst/examples/example-siblings.R bdd1ec730e66d92d08529afa471738e4 *inst/examples/example.R 4690b41a9e1afbbc7754c7b35b9b53d6 *man/accessors.Rd b2a08a839e7876ae14f61a2fcb0bcb85 *man/all_grouping_ids.Rd 583202129076b560602842be4a14a5db *man/all_root_nodes.Rd b4064e619ddd1d141d30639c7d8c0b71 *man/assignments.Rd cc7ab0fad4f2d6b616055af20f88bf4b *man/calls.Rd a2dced0c10b5d176b5d5ff22b65ced0b *man/clean_tag_comments.Rd a2133e7e1fc4a9c1b98ff774115b9a4f *man/extract_test_block.Rd a2670958a736b7e2a6c70e4696f2a195 *man/extract_test_blocks.Rd be64ae1850c3adab5ff98d40166f1cce *man/family-nodes.Rd 2dabd438339e30d8c0d5abbc688aa0fe *man/figures/logo.png 2980aafedb9761aaf3dc6b1aedfe9a20 *man/function-nodes.Rd 756e990310b206a5d768943ac7605f36 *man/get_family_pd.Rd d903265d6651df9a6471c7ef02170c07 *man/get_parse_data.Rd 60d4a722a91af9a7bbeb88baed7e7811 *man/if-statements.Rd e69b08cf3f63725201a2a266b5a3992b *man/iff-blocks.Rd 45b70bbdfe1ccae94dd6645a371cf8bb *man/internal.Rd b092d928bd0c9fe88e292a63ed8291ea *man/n_children.Rd 29892cb6a46a5444853c9f844c25d772 *man/pd_all_tagged_iff_block_ids.Rd ce7006d39381f371f19014542b6de60a *man/pd_class_definitions.Rd 03ede0aa820f5ccb2d8f2cca98da60a6 *man/pd_get_closest_call_id.Rd d7aa156b06362025a7a8e77f69b56178 *man/pd_get_comment_tag_content.Rd 02f45a0dd4c6b9f3fc5d83052f3b7a7a *man/pd_get_iff_associated_name_id.Rd 57a58e3785a02825a79822cf344bedff *man/pd_get_relative_comment_associated_ids.Rd ec880f0c27118c98fb257970e3251b9e *man/pd_get_tagged_comment_ids.Rd e7d46af6eaf5f29e2f2220c8a9704d2c *man/pd_has_tag.Rd 85499b64983a85a440c0718aa56f484f *man/pd_identify.Rd 1a706185c77ae9a13a29faf33a43143d *man/pd_is_comment.Rd 2222fc811b2875eadcfcdd6af19f7688 *man/pd_is_grouping.Rd 32bbef0a2bb1212fd2b215967a556c74 *man/pd_make_is_in_call.Rd 8c65cf4b04f10a18d4892ba66eab0452 *man/pd_reconstitute.Rd 681ef48bfc0d7e3803758d22078b894b *man/root.Rd 83da8eb53a91f3b9663635cf8fe45966 *man/strip_doc_comment_leads.Rd efedc3c047d4eff2f4c9bd28c800b048 *man/strip_tag.Rd d4b51da60b969e9651873bc8ebccadcc *tests/testthat.R 04769de65b2e50ac06996f525ade336e *tests/testthat/test-accessors.R e182d11a1e1c46ac0e983e5c13c85b34 *tests/testthat/test-checks.R dc0cfe1cbae202a0f8fbd6c213d3df86 *tests/testthat/test-children.R c87473e82452b571967bf92c1da9f1e7 *tests/testthat/test-comments.R d632b720d0e05a5c66a21721a24ce0e2 *tests/testthat/test-errors.R bab638bbbaf1956b00fa5a6b4b04f1e8 *tests/testthat/test-family.R f94025376dd5bb290edaa8f31115b1eb *tests/testthat/test-firstborn.R acc437f6dec35d2588e9fdd5a1e44a19 *tests/testthat/test-get_parse_data.R 39acace9c48059dcb3560f02805ed4ba *tests/testthat/test-grouping.R 3cd40bda1b415a58b95425722e61e9f6 *tests/testthat/test-iff_blocks.R da178ec74e514a0b2b558051cd744f75 *tests/testthat/test-internal.R a21844dd8aa3caec7e1b4015b4de3bb5 *tests/testthat/test-parent.R ce3c66791a85e7e9872712dfee1d3dc4 *tests/testthat/test-pd_assign.R 57d6c06cef577a4eaf965dfaf8c9334e *tests/testthat/test-pd_call.R 886d074d6929ec794a6075f04a059869 *tests/testthat/test-pd_classes.R 760b3bfdd1457c405ae3be283da47d80 *tests/testthat/test-pd_comments.R cf19593a698f2906524d491d2db855d2 *tests/testthat/test-pd_function.R 31db2b86ad482276d03078bbacd95408 *tests/testthat/test-pd_identify.R 60390d711ed1cdb768deaa0dda698f1b *tests/testthat/test-pd_if.R 6b7bf326dce7299e3b31341e3d5a801e *tests/testthat/test-pd_make_is_in.R 3ab23bfeedd2996d94529d705384f7c8 *tests/testthat/test-reconstitute.R 2e6461c0bef92d47b6ff44401d06d122 *tests/testthat/test-root.R 2415c82a6e9c4f1085e8d4b94a92c75b *tests/testthat/test-siblings.R 8020eb094a9d437b41deefb9537a4151 *tests/testthat/test-tags.R 4384b120ba4664f763e217bfc732cca3 *tests/testthat/test-testing_blocks.R 7fbc70404281ebc4a9f1d8d4140ad554 *tests/testthat/test-zzz.R 07ec4fd1621c53c050e3717f5943a862 *vignettes/Coding_Conventions.Rmd parsetools/inst/0000755000176200001440000000000013643201236013422 5ustar liggesusersparsetools/inst/examples/0000755000176200001440000000000013401613661015241 5ustar liggesusersparsetools/inst/examples/example-pd.R0000644000176200001440000000026513401545636017431 0ustar liggesusers# load example file and get_parse data ex.file <- system.file("examples", "example.R", package="parsetools") exprs <- parse(ex.file, keep.source = TRUE) pd <- get_parse_data(exprs) parsetools/inst/examples/example-classes.R0000644000176200001440000000040613401550467020456 0ustar liggesusers # Get the 'setClass' call. class.id <- pd_get_assign_value_id(roots[2], pd) # Check to make sure that it is a function that sets a class. pd_is_class_definition(class.id, pd) # and that it is the setClass call. pd_text(pd_get_call_symbol_id(class.id, pd), pd) parsetools/inst/examples/example-assign.R0000644000176200001440000000066413401546341020307 0ustar liggesusers # The first should be an assignment pd_is_assignment(roots[[1]], pd=pd) # the variable/value of the assignment can be accessed by variable.id <- pd_get_assign_variable_id(roots[[1]], pd) value.id <- pd_get_assign_value_id(roots[[1]], pd) # Note that these function will give the variable/value part # for both LEFT_ASSIGN and RIGHT_ASSIGN operators, going by order # of ids, or position in the data may not give the expected results. parsetools/inst/examples/example-children.R0000644000176200001440000000031013401546412020576 0ustar liggesusers # assignments have three children # The operator, the assignment, and the value. kids <- pd_get_children_ids(roots[[1]], pd) # The token tells what kind of node the ids represent. pd_token(kids, pd) parsetools/inst/examples/example-get_parse_data.R0000644000176200001440000000124613511143457021765 0ustar liggesusers 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) tools::assertError(get_parse_data(rnorm), verbose = TRUE) parsetools/inst/examples/example.R0000644000176200001440000000371113643120637017025 0ustar liggesusers# example.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/. # #_____________________________________________________________________# hello_world <- function(greeting="hello", who="world"){ message(paste(greeting, who)) } myClass <- setClass("myClass", contains='list') setMethod("initialize", "myClass", function(.Object, ...){ l <- list(...) if (!all(sapply(l, is, 'character'))) stop("Sorry you are not a winner. Please try again.") else message("Congratulations!") S3Part(.Object) <- list(...) }) parsetools/inst/examples/example-call.R0000644000176200001440000000056713401547652017746 0ustar liggesusers # which root is a call? pd_is_call(roots, pd) id <- roots[pd_is_call(roots, pd)] # not all calls are symbole calls. pd_is_symbol_call(id, pd) # what is the symbol being called? pd_text(pd_get_call_symbol_id(id, pd), pd) # what are the arguments to the call args <- pd_get_call_arg_ids(id, pd) pd_token(pd_get_firstborn(args, pd), pd) pd_text(pd_get_firstborn(args, pd), pd) parsetools/inst/examples/example-roots.R0000644000176200001440000000016313401545711020163 0ustar liggesusers # There are 3 expressions so there should be three roots. sum(pd_is_root(pd$id, pd)) roots <- pd_all_root_ids(pd) parsetools/inst/examples/example-reconstitute.R0000644000176200001440000000003713401554740021547 0ustar liggesusers pd_reconstitute(roots[1], pd) parsetools/inst/examples/example-if.R0000644000176200001440000000055713401560172017420 0ustar liggesusers # Find the if statement is.if <- pd_is_if(pd$id, pd=pd) sum(is.if) if.id <- pd$id[is.if] # The predicate pd_reconstitute(pd_get_if_predicate_id(if.id, pd), pd) # The branch for if predicate evaluates TRUE pd_reconstitute(pd_get_if_branch_id(if.id, pd), pd) # The alternate for if predicate evaluates FALSE pd_reconstitute(pd_get_if_alternate_id(if.id, pd), pd) parsetools/inst/examples/example-siblings.R0000644000176200001440000000050113401551257020625 0ustar liggesusers arg <- pd_get_function_arg_ids(function.id, pd)[1] # All siblings pd_get_sibling_ids(arg, pd) # move to next sibling arg <- pd_get_next_sibling_id(arg, pd) pd_token(arg, pd) # and again arg <- pd_get_next_sibling_id(arg, pd) pd_token(arg, pd) # too far go back arg <- pd_get_prev_sibling_id(arg, pd) pd_text(arg, pd) parsetools/inst/examples/example-function.R0000644000176200001440000000154313401563616020651 0ustar liggesusers function.id <- pd_get_assign_value_id(roots[[1]], pd) pd_is_function(function.id, pd) length(function.kids <- pd_get_children_ids(function.id, pd)) # function nodes have many because it contains # 1. the function keyword. # 2. the parentheses '(' and ')' # 3. each argument name plus the equals sign and value, if given. # 4. and finally, and expr node for the function body. pd_token(function.kids, pd) # even though there are only two argument since each has # a default value given there are 6 total nodes that # return true as function arguments, care is needed when # dealing with function arguments. pd_is_function_arg(function.kids, pd) pd_get_function_arg_ids(function.id, pd) # A simple way to identify the argument names is pd_get_function_arg_variable_text(function.id, pd) # To identify the function body node. pd_get_function_body_id(function.id, pd) parsetools/inst/doc/0000755000176200001440000000000013643201236014167 5ustar liggesusersparsetools/inst/doc/Coding_Conventions.Rmd0000644000176200001440000001100213374664664020440 0ustar liggesusers--- title: "Parsetools Coding Conventions" author: "Andrew Redd" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Parsetools Coding Conventions} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` Coding Conventions for the `parsetools` package =============================================== Functions --------- All the functions in `parsetools` are concerned with `parse-data` objects. Functions either obtain the `parse-data`, such as `get_parse_data()`; convert or transform the parse data, such as `classify_comments()`; identify elements of the parse data tree, such as `pd_is_function()`; or navigate the tree, such as `get_parent_id()`. ### Arguments ### With the exception of obtaining functions and manipulation functions, all function will either take an argument `pd` as a stand alone argument which expects a `parse-data` object, or will take the combination of an `id` and a `pd`, exclusively in that order. The `id` argument is expected to be an integer of values that exist in `pd$id` which denotes the node or nodes of interest. Whether id is a singleton or vector is differentiated by function naming conventions described in the following sections. If there is a need for additional function arguments they must occur after the `id` and `pd` arguments. ### Naming Conventions Overview ### Function names should follow the underscore standard with appropriate prefixes and suffixes, and conform to proper plurality. form Meaning Accepts Returns Exported ------------- ------------------------- ---------- --------------------------- ------------ pd_is_* Logical test function id vector logical 1:1 for input id Yes pd_get_*_id Navigation function id vector id integer 1:1 for input Yes pd_get_*_ids Set identification single id id vector many:1 for input Yes get_*_pd Subsetting id(1)+pd subsetted parse-data No all_*_ids Global sets parse-data id vector many:1 for input No pd_* Other action function id+pd Depending ### Logical Test Functions ### Functions of the form `pd_is_` test if the specified id satisfies the criteria for ``. For example, `pd_is_function(id,pd)` tests if the id identifies a function expression, namely the token for id is `expr`, and the token for the firstborn, i.e. child with minimum id, is `FUNCTION`. These also appear in the form `pd_is_in_`. Example, `pd_is_in_class_definition` tests if the expression is nested inside any defined class definition. ### Navigation Functions ### Functions that get a single id relative to the current id follow the format `pd_get__id`, they may accept a vector of inputs and return a vector of outputs, with each element of the output vector corresponding respectively to the input vector. ### Set Identification Functions ### Function that of the form `pd_get__ids` are set identification functions. They take a single node, and only a single node and return a set of nodes relative to the given node. ## Shortcut functions There are several functions that are shortcuts for internal expressions. These should not be exported but may use the shortcut of defining the function to infer the `pd` argument from the parent function environment, `pd=get('pd', parent.frame())`. Exported functions should not utilize this shortcut. The shortcut functions are renamed with the following conventions: - `pd_is_` → `is_` - `pd_get__id` → `` - `pd_get__ids` → `s` or the appropriate plural form. ## Error Checking Exported functions should perform error checking on arguments. This can be made optional by the .check argument, and when used internally the checking should be turned off. ## Tests In testing code blocks results of output should be directly in the `expect_*` function, or stored in an object called `test.object`. ## Vectorization Functions that return a single id value for each input should vectorize over input. When possible keep the shortest form, if explicit vectorization is needed use: if (length(id) > 1L) return(sapply(id, , pd=pd, , .check=FALSE)) Those that return multiple values for each input id accept only only singleton ids. These functions should check that the input is of length 1. parsetools/inst/doc/Coding_Conventions.R0000644000176200001440000000022513643201235020100 0ustar liggesusers## ----setup, include = FALSE--------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) parsetools/inst/doc/Coding_Conventions.html0000644000176200001440000002447413643201236020660 0ustar liggesusers Parsetools Coding Conventions

Parsetools Coding Conventions

Andrew Redd

2020-04-07

Coding Conventions for the parsetools package

Functions

All the functions in parsetools are concerned with parse-data objects. Functions either obtain the parse-data, such as get_parse_data(); convert or transform the parse data, such as classify_comments(); identify elements of the parse data tree, such as pd_is_function(); or navigate the tree, such as get_parent_id().

Arguments

With the exception of obtaining functions and manipulation functions, all function will either take an argument pd as a stand alone argument which expects a parse-data object, or will take the combination of an id and a pd, exclusively in that order. The id argument is expected to be an integer of values that exist in pd$id which denotes the node or nodes of interest. Whether id is a singleton or vector is differentiated by function naming conventions described in the following sections. If there is a need for additional function arguments they must occur after the id and pd arguments.

Naming Conventions Overview

Function names should follow the underscore standard with appropriate prefixes and suffixes, and conform to proper plurality.

form Meaning Accepts Returns Exported
pd_is_* Logical test function id vector logical 1:1 for input id Yes
pd_get_*_id Navigation function id vector id integer 1:1 for input Yes
pd_get_*_ids Set identification single id id vector many:1 for input Yes
get_*_pd Subsetting id(1)+pd subsetted parse-data No
all_*_ids Global sets parse-data id vector many:1 for input No
pd_* Other action function id+pd Depending

Logical Test Functions

Functions of the form pd_is_<name> test if the specified id satisfies the criteria for <name>. For example, pd_is_function(id,pd) tests if the id identifies a function expression, namely the token for id is expr, and the token for the firstborn, i.e. child with minimum id, is FUNCTION. These also appear in the form pd_is_in_<name>. Example, pd_is_in_class_definition tests if the expression is nested inside any defined class definition.

Set Identification Functions

Function that of the form pd_get_<name>_ids are set identification functions. They take a single node, and only a single node and return a set of nodes relative to the given node.

Shortcut functions

There are several functions that are shortcuts for internal expressions. These should not be exported but may use the shortcut of defining the function to infer the pd argument from the parent function environment, pd=get('pd', parent.frame()).

Exported functions should not utilize this shortcut. The shortcut functions are renamed with the following conventions:

  • pd_is_<name> → is_<name>
  • pd_get_<name>_id → <name>
  • pd_get_<name>_ids → <name>s or the appropriate plural form.

Error Checking

Exported functions should perform error checking on arguments. This can be made optional by the .check argument, and when used internally the checking should be turned off.

Tests

In testing code blocks results of output should be directly in the expect_* function, or stored in an object called test.object.

Vectorization

Functions that return a single id value for each input should vectorize over input. When possible keep the shortest form, if explicit vectorization is needed use:

if (length(id) > 1L) return(sapply(id, <function_name>, pd=pd, <other arguments>, .check=FALSE))

Those that return multiple values for each input id accept only only singleton ids. These functions should check that the input is of length 1.

parsetools/inst/WORDLIST0000644000176200001440000000021713374665017014630 0ustar liggesusersdescendents knitr Redd reparsing rmarkdown vectorization Vectorization vectorize VignetteEncoding VignetteEngine VignetteIndexEntry