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
|
## all extended-taxon-descriptors have:
## - ott_id
## - name
## - rank
## - unique_name
## - tax_sources
## and they may have
## - flags
## - synonyms
## - is_suppressed
## builds the functions to access the content of the taxon descriptors.
## slot: the name of the list element we need to access
## flatten: if the list element is a list, make it a vector
## optional: is the slot found in all taxon descriptors or only in some
tax_access_factory <- function(slot, flatten, optional) {
function(tax) {
if ((!exists(slot, tax))) {
if (optional) {
warning("This object doesn't have ", sQuote(slot), call. = FALSE)
return(NULL)
} else {
stop("Invalid taxon object", call. = FALSE)
}
} else {
if (flatten) {
unlist(tax[[slot]])
} else {
tax[[slot]]
}
}
}
}
.tax_ott_id <- tax_access_factory("ott_id", flatten = FALSE, optional = FALSE)
.tax_name <- tax_access_factory("name", flatten = FALSE, optional = FALSE)
.tax_rank <- tax_access_factory("rank", flatten = FALSE, optional = FALSE)
.tax_sources <- tax_access_factory("tax_sources",
flatten = TRUE,
optional = FALSE
)
.tax_unique_name <- tax_access_factory("unique_name",
flatten = FALSE,
optional = FALSE
)
## optional
.tax_flags <- tax_access_factory("flags", flatten = TRUE, optional = TRUE)
.tax_is_suppressed <- tax_access_factory("is_suppressed",
flatten = FALSE,
optional = TRUE
)
.tax_synonyms <- tax_access_factory("synonyms", flatten = TRUE, optional = TRUE)
## Does the slot element represent a taxon?
is_taxon <- function(slot) {
if (all(c(
"ott_id", "name", "rank", "tax_sources",
"unique_name"
) %in% names(slot))) {
TRUE
} else {
FALSE
}
}
### adds a class to the objects returned by the methods
add_otl_class <- function(res, .f) {
## we need a prefix to avoid class name conflict
## apparently the class "name" already exists
class(res) <- c(
paste0("otl_", as.list(environment(.f))[["slot"]]),
class(res)
)
res
}
##' @export
`[.otl_ott_id` <- function(x, i, ...) {
r <- NextMethod()
class(r) <- class(x)
r
}
|
