1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
|
#' 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)))
}
|
