ropensci / taxize

Compare 6103549 ... +75 ... 5009779

Coverage Reach
classification.R class2tree.R zzz.R get_uid.R get_eolid.R get_wormsid.R get_boldid.R taxize_cite.R get_wiki.R get_tolid.R get_gbifid.R get_tsn.R synonyms.R get_natservid.R get_tpsid.R get_nbnid.R get_pow.R taxa_taxon.R children.R sci2comm.R ping.R downstream.R gnr_resolve.R ncbi_children.R comm2sci.R lowest_common.R id2name.R tax_name.R worms_downstream.R gbif_downstream.R get_iucn.R genbank2uid.R apg.R gbif_helpers.R itis_downstream.R progressor.R eol_pages.R iucn_summary.R bold_search.R ncbi_downstream.R tax_rank.R get_ids.R limited_print.R bold_downstream.R ipni_search.R ncbi_get_taxon_summary.R fungorum.R scrapenames.r gbif_name_usage.R eubon.R taxon_state.R http.R tpl_get.r getkey.R vascan_search.r gni_details.R pow_search.R tax_agg.R upstream.R eol_search.R apg_lookup.R gni_parse.R tol_id2name.R gni_search.R tp_search.R tp_accnames.R rename.R gn_parse.R key_helpers.R get_utils.R tp_synonyms.R tp_summary.R tpl_families.r eol_dataobjects.R itis_hierarchy.R tp_dist.R resolve.R names_list.r ion.R taxize_options.R downstream-utils.R iucn_id.R tp_refs.R nbn_search.R gbif_parse.R iplant_resolve.R itis_lookup.R taxize_capwords.r itis_acceptname.R itis_terms.R aaa.R rankagg.R eubon_children.R eubon_hierarchy.R iucn_getname.R tol_resolve.R nbn_classification.R itis_getrecord.R itis_lsid.R itis_native.R taxize_ldfast.R itis_kingdomnames.R gnr_datasources.R col.R status_codes.R eubon_capabilities.R itis_taxrank.R gni_helpers.R ncbi_getbyname.R get_ubioid.R ncbi_search.R nbn_synonyms.R ncbi_getbyid.R phylomatic_tree.R gisd_isinvasive.R ubio_classification_search.R tp_classification.R tnrs_sources.r ubio_search.R tpl_search.r tnrs.R ubio_classification.R eol_invasive.R plantminer.R eol_utiils.R itis_refs.R itis_name.R ubio_synonyms.R eol_hierarchy.R phylomatic_format.R ubio_id.R

No flags found

Use flags to group coverage reports by test type, project and/or folders.
Then setup custom commit statuses and notifications for each flag.

e.g., #unittest #integration

#production #enterprise

#frontend #backend

Learn more about Codecov Flags here.

Showing 58 of 228 files from the diff.
Newly tracked file
R/itis_lookup.R created.
Newly tracked file
R/taxa_taxon.R created.
Newly tracked file
R/taxize_options.R created.
Other files ignored by Codecov
man/get_gbif.Rd has changed.
man/sci2comm.Rd has changed.
man/tax_rank.Rd has changed.
.gitignore has changed.
man/get_ncbi.Rd has changed.
man/get_eol.Rd has changed.
NAMESPACE has changed.
man/nbn_search.Rd has changed.
man/get_wiki.Rd has changed.
man/synonyms.Rd has changed.
man/pow_search.Rd has changed.
man/downstream.Rd has changed.
R/onload.R has changed.
man/get_worms.Rd has changed.
man/iucn_id.Rd has changed.
man/eol_search.Rd has changed.
.Rbuildignore has changed.
man/get_bold.Rd has changed.
man/tax_name.Rd has changed.
man/plantminer.Rd was deleted.
man/get_tps.Rd has changed.
man/get_tolid.Rd was deleted.
man/upstream.Rd has changed.
man/tax_agg.Rd has changed.
man/children.Rd has changed.
man/get_itis.Rd has changed.
man/names_list.Rd has changed.
man/ping.Rd has changed.
man/id2name.Rd has changed.
man/get_nbn.Rd has changed.
man/comm2sci.Rd has changed.
man/get_ids.Rd has changed.
man/get_iucn.Rd has changed.
man/gni_search.Rd has changed.
man/get_pow.Rd has changed.
DESCRIPTION has changed.

@@ -6,72 +6,70 @@
Loading
6 6
#' @param searchtype character; One of 'scientific' (default) or 'common'.
7 7
#' This doesn't affect the query to NatureServe - but rather affects what
8 8
#' column of data is targeted in name filtering post data request.
9 -
#' @param ask logical; should get_natservid be run in interactive mode?
9 +
#' @param ask logical; should get_natserv be run in interactive mode?
10 10
#' If `TRUE` and more than one wormsid is found for the species, the
11 11
#' user is asked for input. If `FALSE` NA is returned for
12 12
#' multiple matches. default: `TRUE`
13 13
#' @param messages logical; should progress be printed? default: `TRUE`
14 14
#' @param rows numeric; Any number from 1 to infinity. If the default NaN, all
15 15
#' rows are considered. Note that this function still only gives back a
16 -
#' natservid class object with one to many identifiers. See
17 -
#' `get_natservid_()` to get back all, or a subset, of the raw
16 +
#' natserv class object with one to many identifiers. See
17 +
#' `get_natserv_()` to get back all, or a subset, of the raw
18 18
#' data that you are presented during the ask process.
19 -
#' @param x Input to `as.natservid`
19 +
#' @param x Input to `as.natserv`
20 20
#' @param query Deprecated, see `sci_com`
21 21
#' @param ... curl options passed on to [crul::verb-POST]
22 22
#' @param check logical; Check if ID matches any existing on the DB, only
23 -
#' used in [as.natservid()]
23 +
#' used in [as.natserv()]
24 24
#' @template getreturn
25 25
#' @family taxonomic-ids
26 26
#' @seealso [classification()]
27 27
#' @note Authentication no longer required
28 28
#' @examples \dontrun{
29 -
#' (x <- get_natservid("Helianthus annuus", verbose = TRUE))
30 -
#' attributes(x)
31 -
#' attr(x, "match")
32 -
#' attr(x, "multiple_matches")
33 -
#' attr(x, "pattern_match")
34 -
#' attr(x, "uri")
29 +
#' (x <- get_natserv("Helianthus annuus"))
30 +
#' library(taxa2)
31 +
#' tax_name(x)
32 +
#' tax_id(x)
35 33
#'
36 -
#' get_natservid('Gadus morhua')
37 -
#' get_natservid(c("Helianthus annuus", 'Gadus morhua'))
34 +
#' get_natserv('Gadus morhua')
35 +
#' get_natserv(c("Helianthus annuus", 'Gadus morhua'))
38 36
#'
39 37
#' # specify rows to limit choices available
40 -
#' get_natservid('Ruby Quaker Moth', 'common')
41 -
#' get_natservid('Ruby*', 'common')
42 -
#' get_natservid('Ruby*', 'common', rows=1)
43 -
#' get_natservid('Ruby*', 'common', rows=1:2)
38 +
#' get_natserv('Ruby Quaker Moth', 'common')
39 +
#' get_natserv('Ruby*', 'common')
40 +
#' get_natserv('Ruby*', 'common', rows=1)
41 +
#' get_natserv('Ruby*', 'common', rows=1:2)
44 42
#'
45 43
#' # When not found
46 -
#' get_natservid("howdy")
47 -
#' get_natservid(c('Gadus morhua', "howdy"))
44 +
#' get_natserv("howdy")
45 +
#' get_natserv(c('Gadus morhua', "howdy"))
48 46
#'
49 -
#' # Convert a natservid without class information to a natservid class
50 -
#' # already a natservid, returns the same
51 -
#' as.natservid(get_natservid('Pomatomus saltatrix'))
47 +
#' # Convert a natserv without class information to a natserv class
48 +
#' # already a natserv, returns the same
49 +
#' as.natserv(get_natserv('Pomatomus saltatrix'))
52 50
#' # same
53 -
#' as.natservid(get_natservid(c('Gadus morhua', 'Pomatomus saltatrix')))
51 +
#' as.natserv(get_natserv(c('Gadus morhua', 'Pomatomus saltatrix')))
54 52
#' # character
55 -
#' as.natservid(101905)
53 +
#' as.natserv(101905)
56 54
#' # character vector, length > 1
57 -
#' as.natservid(c(101905, 101998))
55 +
#' as.natserv(c(101905, 101998))
58 56
#' # list, either numeric or character
59 -
#' as.natservid(list(101905, 101998))
57 +
#' as.natserv(list(101905, 101998))
60 58
#' ## dont check, much faster
61 -
#' as.natservid(101905, check = FALSE)
62 -
#' as.natservid(c(101905, 101998), check = FALSE)
63 -
#' as.natservid(list(101905, 101998), check = FALSE)
59 +
#' as.natserv(101905, check = FALSE)
60 +
#' as.natserv(c(101905, 101998), check = FALSE)
61 +
#' as.natserv(list(101905, 101998), check = FALSE)
64 62
#'
65 -
#' (out <- as.natservid(c(101905, 101998), check = FALSE))
63 +
#' (out <- as.natserv(c(101905, 101998), check = FALSE))
66 64
#' data.frame(out)
67 -
#' as.natservid( data.frame(out) )
65 +
#' as.natserv( data.frame(out) )
68 66
#'
69 67
#' # Get all data back
70 -
#' get_natservid_("Helianthus")
71 -
#' get_natservid_("Ruby*", searchtype = "common")
72 -
#' get_natservid_("Ruby*", searchtype = "common", rows=1:3)
68 +
#' get_natserv_("Helianthus")
69 +
#' get_natserv_("Ruby*", searchtype = "common")
70 +
#' get_natserv_("Ruby*", searchtype = "common", rows=1:3)
73 71
#' }
74 -
get_natservid <- function(sci_com, searchtype = "scientific", ask = TRUE,
72 +
get_natserv <- function(sci_com, searchtype = "scientific", ask = TRUE,
75 73
                          messages = TRUE, rows = NA, query = NULL, ...) {
76 74
77 75
  assert(sci_com, c("character", "taxon_state"))
@@ -83,10 +81,10 @@
Loading
83 81
  pchk(query, "sci_com")
84 82
85 83
  if (inherits(sci_com, "character")) {
86 -
    tstate <- taxon_state$new(class = "natservid", names = sci_com)
84 +
    tstate <- taxon_state$new(class = "natserv", names = sci_com)
87 85
    items <- sci_com
88 86
  } else {
89 -
    assert_state(sci_com, "natservid")
87 +
    assert_state(sci_com, "natserv")
90 88
    tstate <- sci_com
91 89
    sci_com <- tstate$taxa_remaining()
92 90
    items <- c(sci_com, tstate$taxa_completed())
@@ -99,6 +97,8 @@
Loading
99 97
100 98
  for (i in seq_along(sci_com)) {
101 99
    direct <- FALSE
100 +
    name <- NA_character_
101 +
    nsid <- NA_character_
102 102
    mssg(messages, "\nRetrieving data for taxon '", sci_com[i], "'\n")
103 103
104 104
    if (!searchtype %in% c("scientific", "common")) {
@@ -110,7 +110,6 @@
Loading
110 110
    mm <- NROW(nsdf) > 1
111 111
112 112
    if (!inherits(nsdf, "tbl_df") || NROW(nsdf) == 0) {
113 -
      nsid <- NA_character_
114 113
      att <- "not found"
115 114
    } else {
116 115
      nsdf <- suppressWarnings(data.frame(nsdf))
@@ -119,35 +118,33 @@
Loading
119 118
      # should return NA if spec not found
120 119
      if (nrow(nsdf) == 0) {
121 120
        mssg(messages, m_not_found_sp_altclass)
122 -
        nsid <- NA_character_
123 121
        att <- 'not found'
124 122
      }
125 123
126 124
      # take the one nsid from data.frame
127 125
      if (nrow(nsdf) == 1) {
128 126
        nsid <- nsdf$id
127 +
        name <- nsdf[[grep(searchtype, names(nsdf), value = TRUE)]]
129 128
        att <- 'found'
130 129
      }
131 130
132 131
      # check for direct match
133 132
      if (nrow(nsdf) > 1) {
134 133
135 134
        names(nsdf)[grep(searchtype, names(nsdf))] <- "target"
136 -
        direct <- match(tolower(nsdf$target), tolower(sci_com[i]))
135 +
        # direct <- match(tolower(nsdf$target), tolower(sci_com[i]))
136 +
        matchtmp <- nsdf[as.character(nsdf$target) %in% sci_com[i], ]
137 137
138 -
        if (length(direct) == 1) {
139 -
          if (!all(is.na(direct))) {
140 -
            nsid <- nsdf$id[!is.na(direct)]
138 +
        if (NROW(matchtmp) == 1) {
139 +
          if (!all(is.na(matchtmp))) {
140 +
            nsid <- matchtmp$id
141 +
            name <- matchtmp$target
141 142
            direct <- TRUE
142 143
            att <- 'found'
143 144
          } else {
144 -
            direct <- FALSE
145 -
            nsid <- NA_character_
146 145
            att <- 'not found'
147 146
          }
148 147
        } else {
149 -
          direct <- FALSE
150 -
          nsid <- NA_character_
151 148
          att <- m_na_ask_false_no_direct
152 149
          warning("> 1 result; no direct match found", call. = FALSE)
153 150
        }
@@ -180,101 +177,95 @@
Loading
180 177
            take <- as.numeric(take)
181 178
            message("Input accepted, took taxon '", as.character(nsdf$target[take]), "'.\n")
182 179
            nsid <-  nsdf$id[take]
180 +
            name <-  nsdf$target[take]
183 181
            att <- 'found'
184 182
          } else {
185 -
            nsid <- NA_character_
186 183
            mssg(messages, "\nReturned 'NA'!\n\n")
187 184
            att <- 'not found'
188 185
          }
189 186
        } else {
190 187
          if (length(nsid) != 1) {
191 188
            warning(sprintf(m_more_than_one_found, "NatureServe ID", sci_com[i]),
192 189
              call. = FALSE)
193 -
            nsid <- NA_character_
194 190
            att <- m_na_ask_false
195 191
          }
196 192
        }
197 193
      }
198 194
199 195
    }
200 -
    res <- list(id = as.character(nsid), att = att, multiple = mm,
201 -
      direct = direct)
196 +
    res <- list(id = as.character(nsid), name = name, att = att,
197 +
      multiple = mm, direct = direct)
202 198
    prog$completed(sci_com[i], att)
203 199
    prog$prog(att)
204 200
    tstate$add(sci_com[i], res)
205 201
  }
206 202
  out <- tstate$get()
207 -
  ids <- structure(as.character(unlist(pluck(out, "id"))), class = "natservid",
208 -
                   match = pluck_un(out, "att", ""),
209 -
                   multiple_matches = pluck_un(out, "multiple", logical(1)),
210 -
                   pattern_match = pluck_un(out, "direct", logical(1)))
203 +
  res <- make_taxa_taxon(out, "natserv", rank = "species")
211 204
  on.exit(prog$prog_summary(), add = TRUE)
212 205
  on.exit(tstate$exit, add = TRUE)
213 -
  add_uri(ids, get_url_templates$natserv)
206 +
  return(res)
214 207
}
215 -
216 208
#' @export
217 -
#' @rdname get_natservid
218 -
as.natservid <- function(x, check=TRUE) UseMethod("as.natservid")
209 +
#' @rdname get_natserv
210 +
get_natservid <- function(...) {
211 +
  fchk("get_natservid", "get_natserv")
212 +
  get_natserv(...)
213 +
}
219 214
220 215
#' @export
221 -
#' @rdname get_natservid
222 -
as.natservid.natservid <- function(x, check=TRUE) x
216 +
#' @rdname get_natserv
217 +
as.natserv <- function(x, check=TRUE) UseMethod("as.natserv")
223 218
224 219
#' @export
225 -
#' @rdname get_natservid
226 -
as.natservid.character <- function(x, check=TRUE) if (length(x) == 1) make_natserv(x, check) else collapse(x, make_natserv, "natservid", check = check)
220 +
#' @rdname get_natserv
221 +
as.natserv.natserv <- function(x, check=TRUE) x
227 222
228 223
#' @export
229 -
#' @rdname get_natservid
230 -
as.natservid.list <- function(x, check=TRUE) if (length(x) == 1) make_natserv(x, check) else collapse(x, make_natserv, "natservid", check = check)
224 +
#' @rdname get_natserv
225 +
as.natserv.character <- function(x, check=TRUE) if (length(x) == 1) make_natserv(x, check) else collapse(x, make_natserv, "natserv", check = check)
231 226
232 227
#' @export
233 -
#' @rdname get_natservid
234 -
as.natservid.numeric <- function(x, check=TRUE) as.natservid(as.character(x), check)
228 +
#' @rdname get_natserv
229 +
as.natserv.list <- function(x, check=TRUE) if (length(x) == 1) make_natserv(x, check) else collapse(x, make_natserv, "natserv", check = check)
235 230
236 231
#' @export
237 -
#' @rdname get_natservid
238 -
as.natservid.data.frame <- function(x, check=TRUE) {
239 -
  structure(x$ids, class = "natservid", match = x$match,
240 -
            multiple_matches = x$multiple_matches,
241 -
            pattern_match = x$pattern_match, uri = x$uri)
242 -
}
232 +
#' @rdname get_natserv
233 +
as.natserv.numeric <- function(x, check=TRUE) as.natserv(as.character(x), check)
243 234
244 235
#' @export
245 -
#' @rdname get_natservid
246 -
as.data.frame.natservid <- function(x, ...){
247 -
  data.frame(ids = as.character(unclass(x)),
248 -
             class = "natservid",
249 -
             match = attr(x, "match"),
250 -
             multiple_matches = attr(x, "multiple_matches"),
251 -
             pattern_match = attr(x, "pattern_match"),
252 -
             uri = attr(x, "uri"),
253 -
             stringsAsFactors = FALSE)
254 -
}
236 +
#' @rdname get_natserv
237 +
as.natserv.data.frame <- function(x, check=TRUE) as_txid_df(x, check)
255 238
256 -
make_natserv <- function(x, check=TRUE) make_generic(x, ns_base_uri(), "natservid", check)
239 +
make_natserv <- function(x, check=TRUE) {
240 +
  make_generic(as.character(x), ns_base_uri(), "natserv", check)
241 +
}
257 242
258 -
check_natservid <- function(x){
243 +
check_natserv <- function(x){
259 244
  tt <- crul::HttpClient$new(sprintf(ns_base_uri(), x),
260 245
    headers = tx_ual)$get()$parse("UTF-8")
261 246
  !grepl("No records matched", tt)
262 247
}
263 248
264 249
#' @export
265 -
#' @rdname get_natservid
266 -
get_natservid_ <- function(sci_com, searchtype = "scientific", messages = TRUE,
250 +
#' @rdname get_natserv
251 +
get_natserv_ <- function(sci_com, searchtype = "scientific", messages = TRUE,
267 252
  rows = NA, query = NULL, ...) {
268 253
269 254
  pchk(query, "sci_com")
270 255
  stats::setNames(
271 -
    lapply(sci_com, get_natservid_help, searchtype = searchtype,
256 +
    lapply(sci_com, get_natserv_help, searchtype = searchtype,
272 257
      messages = messages, rows = rows, ...),
273 258
    sci_com
274 259
  )
275 260
}
261 +
#' @export
262 +
#' @rdname get_natserv
263 +
get_natservid_ <- function(...) {
264 +
  fchk("get_natservid_", "get_natserv_")
265 +
  get_natserv_(...)
266 +
}
276 267
277 -
get_natservid_help <- function(sci_com, searchtype, messages, rows, ...) {
268 +
get_natserv_help <- function(sci_com, searchtype, messages, rows, ...) {
278 269
  mssg(messages, "\nRetrieving data for taxon '", sci_com, "'\n")
279 270
  df <- ns_worker(x = sci_com, searchtype = searchtype, ...)
280 271
  sub_rows(df, rows)

@@ -3,7 +3,7 @@
Loading
3 3
#' THIS FUNCTION IS DEFUNCT.
4 4
#'
5 5
#' @export
6 -
#' @author Scott Chamberlain \email{myrmecocystus@@gmail.com}
6 +
#' @author Scott Chamberlain
7 7
#' @rdname ncbi_getbyid-defunct
8 8
#' @keywords internal
9 9
ncbi_getbyid <- function(...) {

@@ -14,8 +14,8 @@
Loading
14 14
#' [classification()]
15 15
#' @param low_rank (character) taxonomic rank to return, of length 1
16 16
#' @param x Deprecated, see `sci_id`
17 -
#' @param ... Other arguments passed to [get_tsn()], [get_uid()],
18 -
#' [get_gbifid()], [get_tolid()]
17 +
#' @param ... Other arguments passed to [get_itis()], [get_ncbi()],
18 +
#' [get_gbif()], [get_tol()]
19 19
#'
20 20
#' @return NA when no match, or a data.frame with columns
21 21
#' * name
@@ -26,7 +26,7 @@
Loading
26 26
#' See [taxize-authentication] for help on authentication
27 27
#' 
28 28
#' @author Jimmy O'Donnell \email{jodonnellbio@@gmail.com}
29 -
#' Scott Chamberlain \email{myrmecocystus@@gmail.com}
29 +
#' Scott Chamberlain
30 30
#' @examples \dontrun{
31 31
#' id <- c("9031", "9823", "9606", "9470")
32 32
#' id_class <- classification(id, db = 'ncbi')
@@ -42,32 +42,32 @@
Loading
42 42
#'   "Masdevallia coccinea")
43 43
#' (cls <- classification(taxa, db = "tol"))
44 44
#' lowest_common(taxa, db = "tol", class_list = cls)
45 -
#' lowest_common(get_tolid(taxa), class_list = cls)
46 -
#' xx <- get_tolid(taxa)
45 +
#' lowest_common(get_tol(taxa), class_list = cls)
46 +
#' xx <- get_tol(taxa)
47 47
#' lowest_common(xx, class_list = cls)
48 48
#'
49 49
#' spp <- c("Sus scrofa", "Homo sapiens", "Nycticebus coucang")
50 50
#' lowest_common(spp, db = "ncbi")
51 -
#' lowest_common(get_uid(spp))
51 +
#' lowest_common(get_ncbi(spp))
52 52
#'
53 53
#' lowest_common(spp, db = "itis")
54 -
#' lowest_common(get_tsn(spp))
54 +
#' lowest_common(get_itis(spp))
55 55
#'
56 56
#' gbifid <- c("2704179", "3119195")
57 57
#' lowest_common(gbifid, db = "gbif")
58 58
#'
59 59
#' spp <- c("Poa annua", "Helianthus annuus")
60 60
#' lowest_common(spp, db = "gbif")
61 -
#' lowest_common(get_gbifid(spp))
61 +
#' lowest_common(get_gbif(spp))
62 62
#'
63 63
#' cool_orchid <- c("Angraecum sesquipedale", "Dracula vampira",
64 64
#'   "Masdevallia coccinea")
65 -
#' orchid_ncbi <- get_uid(cool_orchid)
66 -
#' orchid_gbif <- get_gbifid(cool_orchid)
65 +
#' orchid_ncbi <- get_ncbi(cool_orchid)
66 +
#' orchid_gbif <- get_gbif(cool_orchid)
67 67
#'
68 68
#' cool_orchids2 <- c("Domingoa haematochila", "Gymnadenia conopsea",
69 69
#'   "Masdevallia coccinea")
70 -
#' orchid_itis <- get_tsn(cool_orchids2)
70 +
#' orchid_itis <- get_itis(cool_orchids2)
71 71
#'
72 72
#' orchid_hier_ncbi <- classification(orchid_ncbi, db = 'ncbi')
73 73
#' orchid_hier_gbif <- classification(orchid_gbif, db = 'gbif')
@@ -78,8 +78,8 @@
Loading
78 78
#'   low_rank = 'class')
79 79
#' lowest_common(orchid_gbif, low_rank = 'class')
80 80
#' lowest_common(orchid_gbif, orchid_hier_gbif, low_rank = 'class')
81 -
#' lowest_common(get_uid(cool_orchid), low_rank = 'class')
82 -
#' lowest_common(get_uid(cool_orchid), low_rank = 'family')
81 +
#' lowest_common(get_ncbi(cool_orchid), low_rank = 'class')
82 +
#' lowest_common(get_ncbi(cool_orchid), low_rank = 'family')
83 83
#'
84 84
#' lowest_common(orchid_ncbi, class_list = orchid_hier_ncbi,
85 85
#'   low_rank = 'subfamily')
@@ -91,13 +91,13 @@
Loading
91 91
#'
92 92
#' ## Pass in sci. names
93 93
#' nms <- c("Angraecum sesquipedale", "Dracula vampira", "Masdevallia coccinea")
94 -
#' lowest_common(x = nms, db = "ncbi")
95 -
#' lowest_common(x = nms, db = "gbif")
96 -
#' # lowest_common(x = nms, db = "itis")
94 +
#' lowest_common(nms, db = "ncbi")
95 +
#' lowest_common(nms, db = "gbif")
96 +
#' lowest_common(nms, db = "itis")
97 97
#'
98 98
#' ## NAs due to taxon not found, stops with error message
99 99
#' # lowest_common(orchid_itis, db = "itis")
100 -
#' # lowest_common(get_tsn(cool_orchid))
100 +
#' # lowest_common(get_itis(cool_orchid))
101 101
#' }
102 102
lowest_common <- function(...){
103 103
  UseMethod("lowest_common")
@@ -115,19 +115,19 @@
Loading
115 115
  switch(
116 116
    db,
117 117
    itis = {
118 -
      id <- process_lowest_ids(sci_id, db, get_tsn, rows = rows, ...)
118 +
      id <- process_lowest_ids(sci_id, db, get_itis, rows = rows, ...)
119 119
      lowest_common(id, class_list, ...)
120 120
    },
121 121
    ncbi = {
122 -
      id <- process_lowest_ids(sci_id, db, get_uid, rows = rows, ...)
122 +
      id <- process_lowest_ids(sci_id, db, get_ncbi, rows = rows, ...)
123 123
      lowest_common(id, class_list, ...)
124 124
    },
125 125
    gbif = {
126 -
      id <- process_lowest_ids(sci_id, db, get_gbifid, rows = rows, ...)
126 +
      id <- process_lowest_ids(sci_id, db, get_gbif, rows = rows, ...)
127 127
      lowest_common(id, class_list, ...)
128 128
    },
129 129
    tol = {
130 -
      id <- process_lowest_ids(sci_id, db, get_tolid, rows = rows, ...)
130 +
      id <- process_lowest_ids(sci_id, db, get_tol, rows = rows, ...)
131 131
      lowest_common(id, class_list, ...)
132 132
    },
133 133
    stop("the provided db value was not recognised", call. = FALSE)
@@ -136,40 +136,36 @@
Loading
136 136
137 137
#' @export
138 138
#' @rdname lowest_common
139 -
lowest_common.uid <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
139 +
lowest_common.txid <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
140 +
  fun <- parse(text=paste0("lowest_common_", id_class(sci_id)))
141 +
  eval(fun)(sci_id, class_list, low_rank, ...)
142 +
}
143 +
144 +
lowest_common_ncbi <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
140 145
  check_lowest_ids(sci_id)
141 -
  class_list <- get_class(sci_id, class_list, db = "uid", ...)
146 +
  class_list <- get_class(sci_id, class_list, db = "ncbi", ...)
142 147
  lc_helper(sci_id, class_list, low_rank, ...)
143 148
}
144 -
145 -
#' @export
146 -
#' @rdname lowest_common
147 -
lowest_common.tsn <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
149 +
lowest_common_itis <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
148 150
  check_lowest_ids(sci_id)
149 151
  class_list <- get_class(sci_id, class_list, db = "itis", ...)
150 152
  lc_helper(sci_id, class_list, low_rank, ...)
151 153
}
152 -
153 -
#' @export
154 -
#' @rdname lowest_common
155 -
lowest_common.gbifid <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
154 +
lowest_common_gbif <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
156 155
  check_lowest_ids(sci_id)
157 156
  class_list <- get_class(sci_id, class_list, db = "gbif", ...)
158 157
  lc_helper(sci_id, class_list, low_rank, ...)
159 158
}
160 -
161 -
#' @export
162 -
#' @rdname lowest_common
163 -
lowest_common.tolid <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
159 +
lowest_common_tol <- function(sci_id, class_list = NULL, low_rank = NULL, ...) {
164 160
  check_lowest_ids(sci_id)
165 161
  class_list <- get_class(sci_id, class_list, db = "tol", ...)
166 -
  names(class_list) <- sci_id
162 +
  names(class_list) <- names_or_ids(sci_id)
167 163
  lc_helper(sci_id, class_list, low_rank, ...)
168 164
}
169 165
170 166
# helpers -------------------------------------------------
171 167
lc_helper <- function(x, class_list, low_rank = NULL, ...) {
172 -
  idc <- class_list[x]
168 +
  idc <- tc(class_list[txidac(x)]) %||% tc(class_list[txnameac(x)])
173 169
  # next line NCBI specific
174 170
  cseq <- vapply(idc, function(x) x[1, 1] != "unclassified sequences",
175 171
                 logical(1))
@@ -186,7 +182,6 @@
Loading
186 182
    if (!(low_rank %in% valid_ranks)) {
187 183
      warning('the supplied rank is not valid')
188 184
    }
189 -
    # low_rank_names <- as.character(unique(unlist(lapply(idc, function(x) x$name[which(x$rank == low_rank)]))))
190 185
    low_rank_names <- unique(setDF(rbindlist(lapply(idc, function(x)
191 186
      x[which(x$rank == low_rank),]))))
192 187
    if (NROW(low_rank_names) == 1) {
@@ -208,7 +203,8 @@
Loading
208 203
    if (db == "uid") db <- "ncbi"
209 204
    classification(x, db = db, ...)
210 205
  } else {
211 -
    yattr <- sub("ncbi", "uid", attr(y, "db"))
206 +
    # yattr <- sub("ncbi", "uid", attr(y, "db"))
207 +
    yattr <- attr(y, "db")
212 208
    if (yattr != db) {
213 209
      stop(sprintf("class_list input must be of class '%s'", db), call. = FALSE)
214 210
    }
@@ -228,8 +224,8 @@
Loading
228 224
  g <- tryCatch(as.numeric(as.character(input)), warning = function(e) e)
229 225
  if (inherits(g, "condition")) eval(fxn)(input, ...)
230 226
  if (is.numeric(g) || is.character(input) && all(grepl("[[:digit:]]", input))) {
231 -
    as_fxn <- switch(db, itis = as.tsn, gbif = as.gbifid,
232 -
      ncbi = as.uid, tol = as.tolid)
227 +
    as_fxn <- switch(db, itis = as.itis, gbif = as.gbif,
228 +
      ncbi = as.ncbi, tol = as.tol)
233 229
    as_fxn(input, check = FALSE)
234 230
  } else {
235 231
    eval(fxn)(input, ...)

@@ -8,33 +8,33 @@
Loading
8 8
#' @export
9 9
#' @param sci_com character; one or more scientific or common names. Or,
10 10
#' a `taxon_state` object (see [taxon-state])
11 -
#' @param ask logical; should get_eolid be run in interactive mode?
11 +
#' @param ask logical; should get_eol be run in interactive mode?
12 12
#' If TRUE and more than one ID is found for the species, the user is asked for
13 13
#' input. If FALSE NA is returned for multiple matches.
14 14
#' @param ... Further args passed on to [eol_search()]
15 15
#' @param messages logical; If `TRUE` the actual taxon queried is printed
16 16
#' on the console.
17 17
#' @param rows numeric; Any number from 1 to infinity. If the default NA, all
18 -
#' rows are considered. Note that this function still only gives back a eolid
18 +
#' rows are considered. Note that this function still only gives back a eol
19 19
#' class object with one to many identifiers. See
20 -
#' [get_eolid_()] to get back all, or a subset, of the raw
20 +
#' [get_eol_()] to get back all, or a subset, of the raw
21 21
#' data that you are presented during the ask process.
22 22
#' @param rank (character) A taxonomic rank name. See [rank_ref]
23 23
#' for possible options. Though note that some data sources use atypical ranks,
24 24
#' so inspect the data itself for options. Optional. See `Filtering` below.
25 25
#' @param data_source (character) A data source inside of EOL. These are
26 26
#' longish names like e.g., "Barcode of Life Data Systems" or
27 27
#' "USDA PLANTS images". Optional. See `Filtering` below.
28 -
#' @param x Input to [as.eolid()]
28 +
#' @param x Input to [as.eol()]
29 29
#' @param check logical; Check if ID matches any existing on the DB, only
30 -
#' used in [as.eolid()]
30 +
#' used in [as.eol()]
31 31
#' @param sciname Deprecated, see `sci_com`
32 32
#' @template getreturn
33 33
#'
34 34
#' @family taxonomic-ids
35 35
#' @seealso [classification()]
36 36
#'
37 -
#' @author Scott Chamberlain, \email{myrmecocystus@@gmail.com}
37 +
#' @author Scott Chamberlain
38 38
#'
39 39
#' @details EOL is a bit odd in that they have page IDs for each taxon, but
40 40
#' then within that, they have taxon ids for various taxa within that page
@@ -57,61 +57,61 @@
Loading
57 57
#' removes the rest.
58 58
#'
59 59
#' @examples \dontrun{
60 -
#' get_eolid(sci_com='Pinus contorta')
61 -
#' get_eolid(sci_com='Puma concolor')
60 +
#' get_eol(sci_com='Pinus contorta')
61 +
#' get_eol(sci_com='Puma concolor')
62 62
#'
63 -
#' get_eolid(c("Puma concolor", "Pinus contorta"))
63 +
#' get_eol(c("Puma concolor", "Pinus contorta"))
64 64
#'
65 65
#' # specify rows to limit choices available
66 -
#' get_eolid('Poa annua')
67 -
#' get_eolid('Poa annua', rows=1)
68 -
#' get_eolid('Poa annua', rows=2)
69 -
#' get_eolid('Poa annua', rows=1:2)
66 +
#' get_eol('Poa annua')
67 +
#' get_eol('Poa annua', rows=1)
68 +
#' get_eol('Poa annua', rows=2)
69 +
#' get_eol('Poa annua', rows=1:2)
70 70
#'
71 71
#' # When not found
72 -
#' get_eolid(sci_com="uaudnadndj")
73 -
#' get_eolid(c("Chironomus riparius", "uaudnadndj"))
72 +
#' get_eol(sci_com="uaudnadndj")
73 +
#' get_eol(c("Chironomus riparius", "uaudnadndj"))
74 74
#'
75 75
#' # filter results to a rank or data source, or both
76 -
#' get_eolid("Satyrium")
77 -
#' get_eolid("Satyrium", rank = "genus")
78 -
#' get_eolid("Satyrium", data_source = "INAT")
79 -
#' get_eolid("Satyrium", rank = "genus",
76 +
#' get_eol("Satyrium")
77 +
#' get_eol("Satyrium", rank = "genus")
78 +
#' get_eol("Satyrium", data_source = "inaturalist")
79 +
#' get_eol("Satyrium", rank = "genus",
80 80
#'   data_source = "North Pacific Species List")
81 81
#'
82 -
#' # Convert a eolid without class information to a eolid class
83 -
#' # already a eolid, returns the same
84 -
#' as.eolid(get_eolid("Chironomus riparius"))
82 +
#' # Convert a eol without class information to a eol class
83 +
#' # already a eol, returns the same
84 +
#' as.eol(get_eol("Chironomus riparius"))
85 85
#' # same
86 -
#' as.eolid(get_eolid(c("Chironomus riparius","Pinus contorta")))
86 +
#' as.eol(get_eol(c("Chironomus riparius","Pinus contorta")))
87 87
#' # numeric
88 -
#' as.eolid(10247706)
88 +
#' as.eol(10247706)
89 89
#' # numeric vector, length > 1
90 -
#' as.eolid(c(6985636,12188704,10247706))
90 +
#' as.eol(c(6985636,12188704,10247706))
91 91
#' # character
92 -
#' as.eolid("6985636")
92 +
#' as.eol("6985636")
93 93
#' # character vector, length > 1
94 -
#' as.eolid(c("6985636","12188704","10247706"))
94 +
#' as.eol(c("6985636","12188704","10247706"))
95 95
#' # list, either numeric or character
96 -
#' as.eolid(list("6985636","12188704","10247706"))
96 +
#' as.eol(list("6985636","12188704","10247706"))
97 97
#' ## dont check, much faster
98 -
#' as.eolid("6985636", check=FALSE)
99 -
#' as.eolid(6985636, check=FALSE)
100 -
#' as.eolid(c("6985636","12188704","10247706"), check=FALSE)
101 -
#' as.eolid(list("6985636","12188704","10247706"), check=FALSE)
98 +
#' as.eol("6985636", check=FALSE)
99 +
#' as.eol(6985636, check=FALSE)
100 +
#' as.eol(c("6985636","12188704","10247706"), check=FALSE)
101 +
#' as.eol(list("6985636","12188704","10247706"), check=FALSE)
102 102
#'
103 -
#' (out <- as.eolid(c(6985636,12188704,10247706)))
103 +
#' (out <- as.eol(c(6985636,12188704,10247706)))
104 104
#' data.frame(out)
105 -
#' as.eolid( data.frame(out) )
105 +
#' as.eol( data.frame(out) )
106 106
#'
107 107
#' # Get all data back
108 -
#' get_eolid_("Poa annua")
109 -
#' get_eolid_("Poa annua", rows=2)
110 -
#' get_eolid_("Poa annua", rows=1:2)
111 -
#' get_eolid_(c("asdfadfasd", "Pinus contorta"))
108 +
#' get_eol_("Poa annua")
109 +
#' get_eol_("Poa annua", rows=2)
110 +
#' get_eol_("Poa annua", rows=1:2)
111 +
#' get_eol_(c("asdfadfasd", "Pinus contorta"))
112 112
#' }
113 113
114 -
get_eolid <- function(sci_com, ask = TRUE, messages = TRUE,
114 +
get_eol <- function(sci_com, ask = TRUE, messages = TRUE,
115 115
  rows = NA, rank = NULL, data_source = NULL, sciname = NULL, ...) {
116 116
117 117
  assert(sci_com, c("character", "taxon_state"))
@@ -123,10 +123,10 @@
Loading
123 123
  pchk(sciname, "sci_com")
124 124
125 125
  if (inherits(sci_com, "character")) {
126 -
    tstate <- taxon_state$new(class = "eolid", names = sci_com)
126 +
    tstate <- taxon_state$new(class = "eol", names = sci_com)
127 127
    items <- sci_com
128 128
  } else {
129 -
    assert_state(sci_com, "eolid")
129 +
    assert_state(sci_com, "eol")
130 130
    tstate <- sci_com
131 131
    sci_com <- tstate$taxa_remaining()
132 132
    items <- c(sci_com, tstate$taxa_completed())
@@ -139,13 +139,16 @@
Loading
139 139
140 140
  for (i in seq_along(sci_com)) {
141 141
    direct <- FALSE
142 +
    id <- NA_character_
143 +
    page_id <- NA_character_
144 +
    name <- NA_character_
145 +
    rank_taken <- NA_character_
146 +
    datasource <- NA_character_
147 +
    
142 148
    mssg(messages, "\nRetrieving data for taxon '", sci_com[i], "'\n")
143 149
    tmp <- eol_search(sci = sci_com[i], ...)
144 -
    datasource <- NA_character_
145 150
    if (all(is.na(tmp))) {
146 151
      mssg(messages, m_not_found_sp_altclass)
147 -
      id <- NA_character_
148 -
      page_id <- NA_character_
149 152
      att <- "not found"
150 153
      mm <- FALSE
151 154
    } else {
@@ -155,7 +158,6 @@
Loading
155 158
        if (nrow(tmp) > 0)
156 159
        mssg(messages, paste(m_not_found_sp_altclass, sprintf("\nDid find: %s",
157 160
                                        paste(tmp$name, collapse = "; "))))
158 -
        id <- NA_character_
159 161
      } else {
160 162
        dfs <- lapply(pageids, function(x) {
161 163
          y <- tryCatch(eol_pages(x), error = function(e) e)
@@ -176,8 +178,6 @@
Loading
176 178
177 179
        if (nrow(df) == 0) {
178 180
          mssg(messages, m_not_found_sp_altclass)
179 -
          id <- NA_character_
180 -
          page_id <- NA_character_
181 181
        } else{
182 182
          id <- df$eolid
183 183
        }
@@ -188,16 +188,16 @@
Loading
188 188
    # not found on eol
189 189
    if (length(id) == 0 || all(is.na(id))) {
190 190
      mssg(messages, m_not_found_sp_altclass)
191 -
      id <- NA_character_
192 -
      page_id <- NA_character_
193 191
			mm <- FALSE
194 192
      att <- "not found"
195 193
    }
196 194
    # only one found on eol
197 195
    if (length(id) == 1 & !all(is.na(id))) {
198 196
      id <- df$eolid
199 197
      page_id <- df$pageid
200 -
      datasource <- df$source
198 +
      datasource <- df$source %||% NA_character_
199 +
      name <- df$name
200 +
      rank_taken <- df$rank
201 201
      direct <- TRUE
202 202
      att <- "found"
203 203
    }
@@ -208,16 +208,14 @@
Loading
208 208
      df <- filt(df, "source", data_source)
209 209
      id <- df$eolid
210 210
      page_id <- df$pageid
211 -
      datasource <- df$source
211 +
      datasource <- df$source %||% NA_character_
212 212
      att <- "found"
213 213
    }
214 214
215 215
    if (length(id) == 0 || all(is.na(id))) {
216 216
      mssg(messages, m_not_found_sp_altclass)
217 -
      id <- NA_character_
218 -
      page_id <- NA_character_
219 -
      datasource <- NA_character_
220 217
      mm <- FALSE
218 +
      id <- NA_character_
221 219
      att <- "not found"
222 220
    }
223 221
@@ -228,6 +226,8 @@
Loading
228 226
        direct <- TRUE
229 227
        page_id <- matchtmp$pageid
230 228
        datasource <- matchtmp$source
229 +
        name <- matchtmp$name
230 +
        rank_taken <- matchtmp$rank
231 231
        att <- "found"
232 232
      }
233 233
    }
@@ -254,42 +254,53 @@
Loading
254 254
          names(id) <- as.character(df$pageid[take])
255 255
          page_id <- as.character(df$pageid[take])
256 256
          datasource <- as.character(df$source[take])
257 +
          name <- as.character(df$name[take])
258 +
          rank_taken <- as.character(df$rank[take])
257 259
          att <- "found"
258 260
        } else {
259 -
          id <- NA_character_
260 -
          page_id <- NA_character_
261 261
          att <- "not found"
262 262
          mssg(messages, "\nReturned 'NA'!\n\n")
263 263
        }
264 264
      } else {
265 265
        if (length(id) != 1) {
266 266
          warning(sprintf(m_more_than_one_found, "eolid", sci_com[i]),
267 267
            call. = FALSE)
268 -
          id <- NA_character_
269 -
          page_id <- NA_character_
270 268
          att <- m_na_ask_false
271 269
        }
272 270
      }
273 271
    }
274 -
    res <- list(id = as.character(id), page_id = page_id, source = datasource, 
275 -
      att = att, multiple = mm, direct = direct)
272 +
    res <- list(id = as.character(id), page_id = page_id, source = datasource,
273 +
      name = name, rank = rank_taken, att = att,
274 +
      multiple = mm, direct = direct)
276 275
    prog$completed(sci_com[i], att)
277 276
    prog$prog(att)
278 277
    tstate$add(sci_com[i], res)
279 278
  }
280 279
  out <- tstate$get()
281 -
  page_ids <- pluck_un(out, "page_id", "")
282 -
  ids <- structure(
283 -
    pluck_un(out, "id", ""), class = "eolid",
284 -
    pageid = page_ids,
285 -
    provider = pluck_un(out, "source", ""),
286 -
    match = pluck_un(out, "att", ""),
287 -
    multiple_matches = pluck_un(out, "multiple", logical(1)),
288 -
    pattern_match = pluck_un(out, "direct", logical(1))
280 +
  page_ids <- as.character(unlist(pluck(out, "page_id")))
281 +
  provider <- pluck_un(out, "source", "")
282 +
  misc <- jsonlite::toJSON(list(page_ids=page_ids, provider=provider))
283 +
  ids <- pluck_un(out, "id", "")
284 +
  res <- taxa_taxon(
285 +
    name = unlist(pluck(out, "name")),
286 +
    id = taxa2::taxon_id(ids, db = "eol"),
287 +
    rank = unlist(pluck(out, "rank")),
288 +
    uri = sprintf(get_url_templates$eol, ids),
289 +
    match = unname(unlist(pluck(out, "att"))),
290 +
    multiple_matches = unname(unlist(pluck(out, "multiple"))) %||% NA,
291 +
    pattern_match = unname(unlist(pluck(out, "direct"))) %||% NA,
292 +
    misc = as.character(misc),
293 +
    class = "eol"
289 294
  )
290 295
  on.exit(prog$prog_summary(), add = TRUE)
291 296
  on.exit(tstate$exit, add = TRUE)
292 -
  add_uri(ids, get_url_templates$eol, page_ids)
297 +
  return(res)
298 +
}
299 +
#' @export
300 +
#' @rdname get_eol
301 +
get_eolid <- function(...) {
302 +
  fchk("get_eolid", "get_eol")
303 +
  get_eol(...)
293 304
}
294 305
295 306
taxize_sort_df <- function(data, vars = names(data)) {
@@ -299,65 +310,47 @@
Loading
299 310
}
300 311
301 312
#' @export
302 -
#' @rdname get_eolid
303 -
as.eolid <- function(x, check=TRUE) {
304 -
  UseMethod("as.eolid")
313 +
#' @rdname get_eol
314 +
as.eol <- function(x, check=TRUE) {
315 +
  UseMethod("as.eol")
305 316
}
306 317
307 318
#' @export
308 -
#' @rdname get_eolid
309 -
as.eolid.eolid <- function(x, check=TRUE) {
310 -
  x
311 -
}
319 +
#' @rdname get_eol
320 +
as.eol.txid <- function(x, check=TRUE) x
312 321
313 322
#' @export
314 -
#' @rdname get_eolid
315 -
as.eolid.character <- function(x, check=TRUE) {
323 +
#' @rdname get_eol
324 +
as.eol.character <- function(x, check=TRUE) {
316 325
  if (length(x) == 1) {
317 -
    make_eolid(x, check)
326 +
    make_eol(x, check)
318 327
  } else {
319 -
    collapse(x, fxn = make_eolid, class = "eolid", check = check)
328 +
    collapse(x, fxn = make_eol, class = "eol", check = check)
320 329
  }
321 330
}
322 331
323 332
#' @export
324 -
#' @rdname get_eolid
325 -
as.eolid.list <- function(x, check=TRUE) {
333 +
#' @rdname get_eol
334 +
as.eol.list <- function(x, check=TRUE) {
326 335
  if (length(x) == 1) {
327 -
    make_eolid(x, check)
336 +
    make_eol(x, check)
328 337
  } else {
329 -
    collapse(x, make_eolid, "eolid", check = check)
338 +
    collapse(x, make_eol, "eol", check = check)
330 339
  }
331 340
}
332 341
333 342
#' @export
334 -
#' @rdname get_eolid
335 -
as.eolid.numeric <- function(x, check=TRUE) {
336 -
  as.eolid(as.character(x), check)
343 +
#' @rdname get_eol
344 +
as.eol.numeric <- function(x, check=TRUE) {
345 +
  as.eol(as.character(x), check)
337 346
}
338 347
339 348
#' @export
340 -
#' @rdname get_eolid
341 -
as.eolid.data.frame <- function(x, check=TRUE) {
342 -
  structure(x$ids, class = "eolid", match = x$match,
343 -
            multiple_matches = x$multiple_matches,
344 -
            pattern_match = x$pattern_match, uri = x$uri)
345 -
}
349 +
#' @rdname get_eol
350 +
as.eol.data.frame <- function(x, check=TRUE) as_txid_df(x, check)
346 351
347 -
#' @export
348 -
#' @rdname get_eolid
349 -
as.data.frame.eolid <- function(x, ...){
350 -
  data.frame(ids = as.character(unclass(x)),
351 -
             class = "eolid",
352 -
             match = attr(x, "match"),
353 -
             multiple_matches = attr(x, "multiple_matches"),
354 -
             pattern_match = attr(x, "pattern_match"),
355 -
             uri = attr(x, "uri"),
356 -
             stringsAsFactors = FALSE)
357 -
}
358 -
359 -
make_eolid <- function(x, check=TRUE) {
360 -
  tmp <- make_generic(x, 'https://eol.org/pages/%s/overview', "eolid", check)
352 +
make_eol <- function(x, check=TRUE) {
353 +
  tmp <- make_generic(x, 'https://eol.org/pages/%s/overview', "eol", check)
361 354
  if (!check) {
362 355
    attr(tmp, "uri") <- NA_character_
363 356
  } else {
@@ -371,7 +364,7 @@
Loading
371 364
  tmp
372 365
}
373 366
374 -
check_eolid <- function(x) {
367 +
check_eol <- function(x) {
375 368
  url <- sprintf("https://eol.org/api/hierarchy_entries/1.0/%s.json", x)
376 369
  tryid <- tax_GET_nocheck(url)
377 370
  if (tryid$status_code == 200) TRUE else FALSE
@@ -388,15 +381,21 @@
Loading
388 381
}
389 382
390 383
#' @export
391 -
#' @rdname get_eolid
392 -
get_eolid_ <- function(sci_com, messages = TRUE, rows = NA, sciname = NULL,
384 +
#' @rdname get_eol
385 +
get_eol_ <- function(sci_com, messages = TRUE, rows = NA, sciname = NULL,
393 386
  ...) {
394 387
  pchk(sciname, "sci_com")
395 -
  stats::setNames(lapply(sci_com, get_eolid_help, messages = messages,
388 +
  stats::setNames(lapply(sci_com, get_eol_help, messages = messages,
396 389
                  rows = rows, ...), sci_com)
397 390
}
391 +
#' @export
392 +
#' @rdname get_eol
393 +
get_eolid_ <- function(...) {
394 +
  fchk("get_eolid_", "get_eol_")
395 +
  get_eol_(...)
396 +
}
398 397
399 -
get_eolid_help <- function(sci_com, messages, rows, ...) {
398 +
get_eol_help <- function(sci_com, messages, rows, ...) {
400 399
  mssg(messages, "\nRetrieving data for taxon '", sci_com, "'\n")
401 400
  tmp <- eol_search(sci_com, ...)
402 401

@@ -3,24 +3,24 @@
Loading
3 3
#' @export
4 4
#' @param sci (character) One or more scientific name's as a vector or list. Or,
5 5
#' a `taxon_state` object (see [taxon-state])
6 -
#' @param ask logical; should get_tpsid be run in interactive mode?
6 +
#' @param ask logical; should get_tps be run in interactive mode?
7 7
#' If TRUE and more than one ID is found for the species, the user is asked for
8 8
#' input. If FALSE NA is returned for multiple matches.
9 9
#' @param messages logical; If TRUE the actual taxon queried is printed on the console.
10 10
#' @param key Your API key; see [taxize-authentication]
11 11
#' @param rows numeric; Any number from 1 to infinity. If the default NA, all rows are considered.
12 -
#' Note that this function still only gives back a tpsid class object with one to many identifiers.
13 -
#' See [get_tpsid_()] to get back all, or a subset, of the raw data that you are
12 +
#' Note that this function still only gives back a tps class object with one to many identifiers.
13 +
#' See [get_tps_()] to get back all, or a subset, of the raw data that you are
14 14
#' presented during the ask process.
15 15
#' @param family (character) A family name. Optional. See `Filtering` below.
16 16
#' @param rank (character) A taxonomic rank name. See [rank_ref] for possible
17 17
#' options. Though note that some data sources use atypical ranks, so inspect the
18 18
#' data itself for options. Optional. See `Filtering` below.
19 19
#' @param sciname Deprecated, see `sci`
20 20
#' @param ... Other arguments passed to [tp_search()].
21 -
#' @param x Input to [as.tpsid()]
21 +
#' @param x Input to [as.tps()]
22 22
#' @param check logical; Check if ID matches any existing on the DB, only used in
23 -
#' [as.tpsid()]
23 +
#' [as.tps()]
24 24
#' @template getreturn
25 25
#'
26 26
#' @section Filtering:
@@ -32,76 +32,74 @@
Loading
32 32
#'
33 33
#' @family taxonomic-ids
34 34
#' @seealso [classification()]
35 -
#'
36 -
#' @author Scott Chamberlain, \email{myrmecocystus@@gmail.com}
37 -
#'
35 +
#' @author Scott Chamberlain
38 36
#' @examples \dontrun{
39 -
#' get_tpsid(sci='Poa annua')
40 -
#' get_tpsid(sci='Pinus contorta')
37 +
#' get_tps(sci='Poa annua')
38 +
#' get_tps(sci='Pinus contorta')
41 39
#'
42 -
#' get_tpsid(c("Poa annua", "Pinus contorta"))
40 +
#' get_tps(c("Poa annua", "Pinus contorta"))
43 41
#'
44 42
#' # specify rows to limit choices available
45 -
#' get_tpsid('Poa ann')
46 -
#' get_tpsid('Poa ann', rows=1)
47 -
#' get_tpsid('Poa ann', rows=25)
48 -
#' get_tpsid('Poa ann', rows=1:2)
43 +
#' get_tps('Poa ann')
44 +
#' get_tps('Poa ann', rows=1)
45 +
#' get_tps('Poa ann', rows=25)
46 +
#' get_tps('Poa ann', rows=1:2)
49 47
#'
50 48
#' # When not found, NA given (howdy is not a species name, and Chrinomus is a fly)
51 -
#' get_tpsid("howdy")
52 -
#' get_tpsid(c("Chironomus riparius", "howdy"))
49 +
#' get_tps("howdy")
50 +
#' get_tps(c("Chironomus riparius", "howdy"))
53 51
#'
54 52
#' # Narrow down results to a division or rank, or both
55 53
#' ## Satyrium example
56 54
#' ### Results w/o narrowing
57 -
#' get_tpsid("Satyrium")
55 +
#' get_tps("Satyrium")
58 56
#' ### w/ rank
59 -
#' get_tpsid("Satyrium", rank = "var.")
60 -
#' get_tpsid("Satyrium", rank = "sp.")
57 +
#' get_tps("Satyrium", rank = "var.")
58 +
#' get_tps("Satyrium", rank = "sp.")
61 59
#'
62 60
#' ## w/ family
63 -
#' get_tpsid("Poa")
64 -
#' get_tpsid("Poa", family = "Iridaceae")
65 -
#' get_tpsid("Poa", family = "Orchidaceae")
66 -
#' get_tpsid("Poa", family = "Orchidaceae", rank = "gen.")
61 +
#' get_tps("Poa")
62 +
#' get_tps("Poa", family = "Iridaceae")
63 +
#' get_tps("Poa", family = "Orchidaceae")
64 +
#' get_tps("Poa", family = "Orchidaceae", rank = "gen.")
67 65
#'
68 66
#' # Fuzzy filter on any filtering fields
69 67
#' ## uses grep on the inside
70 -
#' get_tpsid("Poa", family = "orchidaceae")
71 -
#' get_tpsid("Aga", fuzzy = TRUE, parent = "*idae")
68 +
#' get_tps("Poa", family = "orchidaceae")
69 +
#' get_tps("Aga", fuzzy = TRUE, parent = "*idae")
72 70
#'
73 71
#' # pass to classification function to get a taxonomic hierarchy
74 -
#' classification(get_tpsid(sci='Poa annua'))
72 +
#' classification(get_tps(sci='Poa annua'))
75 73
#'
76 -
#' # Convert a tpsid without class information to a tpsid class
77 -
#' as.tpsid(get_tpsid("Pinus contorta")) # already a tpsid, returns the same
78 -
#' as.tpsid(get_tpsid(c("Chironomus riparius","Pinus contorta"))) # same
79 -
#' as.tpsid(24900183) # numeric
80 -
#' as.tpsid(c(24900183,50150089,50079838)) # numeric vector, length > 1
81 -
#' as.tpsid("24900183") # character
82 -
#' as.tpsid(c("24900183","50150089","50079838")) # character vector, length > 1
83 -
#' as.tpsid(list("24900183","50150089","50079838")) # list, either numeric or character
74 +
#' # Convert a tps without class information to a tps class
75 +
#' as.tps(get_tps("Pinus contorta")) # already a tps, returns the same
76 +
#' as.tps(get_tps(c("Chironomus riparius","Pinus contorta"))) # same
77 +
#' as.tps(24900183) # numeric
78 +
#' as.tps(c(24900183,50150089,50079838)) # numeric vector, length > 1
79 +
#' as.tps("24900183") # character
80 +
#' as.tps(c("24900183","50150089","50079838")) # character vector, length > 1
81 +
#' as.tps(list("24900183","50150089","50079838")) # list, either numeric or character
84 82
#' ## dont check, much faster
85 -
#' as.tpsid("24900183", check=FALSE)
86 -
#' as.tpsid(24900183, check=FALSE)
87 -
#' as.tpsid(c("24900183","50150089","50079838"), check=FALSE)
88 -
#' as.tpsid(list("24900183","50150089","50079838"), check=FALSE)
83 +
#' as.tps("24900183", check=FALSE)
84 +
#' as.tps(24900183, check=FALSE)
85 +
#' as.tps(c("24900183","50150089","50079838"), check=FALSE)
86 +
#' as.tps(list("24900183","50150089","50079838"), check=FALSE)
89 87
#'
90 -
#' (out <- as.tpsid(c(24900183,50150089,50079838)))
88 +
#' (out <- as.tps(c(24900183,50150089,50079838)))
91 89
#' data.frame(out)
92 -
#' as.tpsid( data.frame(out) )
90 +
#' as.tps( data.frame(out) )
93 91
#'
94 92
#' # Get all data back
95 -
#' get_tpsid_("Poa annua")
96 -
#' get_tpsid_("Poa annua", rows=2)
97 -
#' get_tpsid_("Poa annua", rows=1:2)
98 -
#' get_tpsid_(c("asdfadfasd","Pinus contorta"), rows=1:5)
93 +
#' get_tps_("Poa annua")
94 +
#' get_tps_("Poa annua", rows=2)
95 +
#' get_tps_("Poa annua", rows=1:2)
96 +
#' get_tps_(c("asdfadfasd","Pinus contorta"), rows=1:5)
99 97
#'
100 98
#' # use curl options
101 -
#' invisible(get_tpsid("Quercus douglasii", messages = TRUE))
99 +
#' invisible(get_tps("Quercus douglasii", messages = TRUE))
102 100
#' }
103 101
104 -
get_tpsid <- function(sci, ask = TRUE, messages = TRUE, key = NULL,
102 +
get_tps <- function(sci, ask = TRUE, messages = TRUE, key = NULL,
105 103
  rows = NA, family = NULL, rank = NULL, sciname = NULL, ...) {
106 104
107 105
  assert(sci, c("character", "taxon_state"))
@@ -113,10 +111,10 @@
Loading
113 111
  pchk(sciname, "sci")
114 112
115 113
  if (inherits(sci, "character")) {
116 -
    tstate <- taxon_state$new(class = "tpsid", names = sci)
114 +
    tstate <- taxon_state$new(class = "tps", names = sci)
117 115
    items <- sci
118 116
  } else {
119 -
    assert_state(sci, "tpsid")
117 +
    assert_state(sci, "tps")
120 118
    tstate <- sci
121 119
    sci <- tstate$taxa_remaining()
122 120
    items <- c(sci, tstate$taxa_completed())
@@ -129,6 +127,9 @@
Loading
129 127
130 128
  for (i in seq_along(sci)) {
131 129
    direct <- FALSE
130 +
    id <- NA_character_
131 +
    name <- NA_character_
132 +
    rank_taken <- NA_character_
132 133
    mssg(messages, "\nRetrieving data for taxon '", sci[i], "'\n")
133 134
    tmp <- tp_search(sci = sci[i], key = key, ...)
134 135
    mm <- NROW(tmp) > 1
@@ -139,7 +140,6 @@
Loading
139 140
      inherits(tmp, "character")
140 141
    ) {
141 142
      mssg(messages, m_not_found_sp_altclass)
142 -
      id <- NA_character_
143 143
      att <- "not found"
144 144
    } else {
145 145
      df <- tmp[, c('nameid','scientificname','family','rankabbreviation',
@@ -152,9 +152,15 @@
Loading
152 152
    # not found on tropicos
153 153
    if (length(id) == 0) {
154 154
      mssg(messages, m_not_found_sp_altclass)
155 -
      id <- NA_character_
156 155
      att <- "not found"
157 156
    }
157 +
    # found on tropicos, length 1
158 +
    if (length(id) == 1 && att == "found") {
159 +
      att <- "found"
160 +
      direct <- TRUE
161 +
      rank_taken <- rank_swap(df$rank)
162 +
      name <- df$name
163 +
    }
158 164
    # more than one found on tropicos -> user input
159 165
    if (length(id) > 1) {
160 166
@@ -163,19 +169,24 @@
Loading
163 169
          df <- filt(df, "rank", rank)
164 170
        }
165 171
172 +
        df$rank <- rank_swap(df$rank)
173 +
166 174
        df <- sub_rows(df, rows)
167 175
        id <- df$tpsid
168 176
        if (length(id) == 1) {
169 177
          rank_taken <- as.character(df$rank)
178 +
          name <- df$name
170 179
          direct <- TRUE
171 180
          att <- "found"
172 181
        }
173 182
174 183
        # more than one, try for direct match
175 184
        if (length(id) > 1) {
176 -
          matchtmp <- df[tolower(df$name) %in% tolower(sci[i]), "tpsid"]
177 -
          if (length(matchtmp) == 1) {
178 -
            id <- matchtmp
185 +
          matchtmp <- df[tolower(df$name) %in% tolower(sci[i]), ]
186 +
          if (NROW(matchtmp) == 1) {
187 +
            id <- matchtmp$tpsid
188 +
            rank_taken <- as.character(matchtmp$rank)
189 +
            name <- matchtmp$name
179 190
            direct <- TRUE
180 191
            att <- "found"
181 192
          }
@@ -186,7 +197,7 @@
Loading
186 197
            # prompt
187 198
            rownames(df) <- 1:nrow(df)
188 199
            message("\n\n")
189 -
            message("\nMore than one tpsid found for taxon '", sci[i], "'!\n
200 +
            message("\nMore than one tps ID found for taxon '", sci[i], "'!\n
190 201
          Enter rownumber of taxon (other inputs will return 'NA'):\n")
191 202
            rownames(df) <- 1:nrow(df)
192 203
            print(df)
@@ -198,97 +209,91 @@
Loading
198 209
            }
199 210
            if (take %in% seq_len(nrow(df))) {
200 211
              take <- as.numeric(take)
201 -
              message("Input accepted, took tpsid '", as.character(df$tpsid[take]), "'.\n")
212 +
              message("Input accepted, took tps ID '", as.character(df$tpsid[take]), "'.\n")
202 213
              id <- as.character(df$tpsid[take])
214 +
              rank_taken <- as.character(df$rank[take])
215 +
              name <- df$name[take]
203 216
              att <- "found"
204 217
            } else {
205 -
              id <- NA_character_
206 218
              mssg(messages, "\nReturned 'NA'!\n\n")
207 219
              att <- "not found"
208 220
            }
209 221
          } else {
210 222
            if (length(id) != 1) {
211 -
              warning(sprintf(m_more_than_one_found, "tpsid", sci[i]),
223 +
              warning(sprintf(m_more_than_one_found, "tps ID", sci[i]),
212 224
                call. = FALSE)
213 -
              id <- NA_character_
214 225
              att <- m_na_ask_false
215 226
            }
216 227
          }
217 228
        }
218 229
    }
219 -
    res <- list(id = as.character(id), att = att, multiple = mm, direct = direct)
230 +
    res <- list(id = as.character(id), name = name, rank = rank_taken,
231 +
      att = att, multiple = mm, direct = direct)
220 232
    prog$completed(sci[i], att)
221 233
    prog$prog(att)
222 234
    tstate$add(sci[i], res)
223 235
  }
224 236
  out <- tstate$get()
225 -
  ids <- structure(as.character(unlist(pluck(out, "id"))), class = "tpsid",
226 -
                   match = pluck_un(out, "att", ""),
227 -
                   multiple_matches = pluck_un(out, "multiple", logical(1)),
228 -
                   pattern_match = pluck_un(out, "direct", logical(1)))
237 +
  res <- make_taxa_taxon(out, "tps")
229 238
  on.exit(prog$prog_summary(), add = TRUE)
230 239
  on.exit(tstate$exit, add = TRUE)
231 -
  add_uri(ids, get_url_templates$tropicos)
240 +
  return(res)
232 241
}
233 -
234 242
#' @export
235 -
#' @rdname get_tpsid
236 -
as.tpsid <- function(x, check=TRUE) UseMethod("as.tpsid")
243 +
#' @rdname get_tps
244 +
get_tpsid <- function(...) {
245 +
  fchk("get_tpsid", "get_tps")
246 +
  get_tps(...)
247 +
}
237 248
238 249
#' @export
239 -
#' @rdname get_tpsid
240 -
as.tpsid.tpsid <- function(x, check=TRUE) x
250 +
#' @rdname get_tps
251 +
as.tps <- function(x, check=TRUE) UseMethod("as.tps")
241 252
242 253
#' @export
243 -
#' @rdname get_tpsid
244 -
as.tpsid.character <- function(x, check=TRUE) if(length(x) == 1) make_tpsid(x, check) else collapse(x, make_tpsid, "tpsid", check=check)
254 +
#' @rdname get_tps
255 +
as.tps.tps <- function(x, check=TRUE) x
245 256
246 257
#' @export
247 -
#' @rdname get_tpsid
248 -
as.tpsid.list <- function(x, check=TRUE) if(length(x) == 1) make_tpsid(x, check) else collapse(x, make_tpsid, "tpsid", check=check)
258 +
#' @rdname get_tps
259 +
as.tps.character <- function(x, check=TRUE) if(length(x) == 1) make_tps(x, check) else collapse(x, make_tps, "tps", check=check)
249 260
250 261
#' @export
251 -
#' @rdname get_tpsid
252 -
as.tpsid.numeric <- function(x, check=TRUE) as.tpsid(as.character(x), check)
262 +
#' @rdname get_tps
263 +
as.tps.list <- function(x, check=TRUE) if(length(x) == 1) make_tps(x, check) else collapse(x, make_tps, "tps", check=check)
253 264
254 265
#' @export
255 -
#' @rdname get_tpsid
256 -
as.tpsid.data.frame <- function(x, check=TRUE) {
257 -
  structure(x$ids, class="tpsid", match=x$match,
258 -
            multiple_matches = x$multiple_matches,
259 -
            pattern_match = x$pattern_match, uri=x$uri)
260 -
}
266 +
#' @rdname get_tps
267 +
as.tps.numeric <- function(x, check=TRUE) as.tps(as.character(x), check)
261 268
262 269
#' @export
263 -
#' @rdname get_tpsid
264 -
as.data.frame.tpsid <- function(x, ...){
265 -
  data.frame(ids = as.character(unclass(x)),
266 -
             class = "tpsid",
267 -
             match = attr(x, "match"),
268 -
             multiple_matches = attr(x, "multiple_matches"),
269 -
             pattern_match = attr(x, "pattern_match"),
270 -
             uri = attr(x, "uri"),
271 -
             stringsAsFactors = FALSE)
272 -
}
270 +
#' @rdname get_tps
271 +
as.tps.data.frame <- function(x, check=TRUE) as_txid_df(x, check)
273 272
274 -
make_tpsid <- function(x, check=TRUE) make_generic(x, 'http://tropicos.org/Name/%s', "tpsid", check)
273 +
make_tps <- function(x, check=TRUE) make_generic(x, 'http://tropicos.org/Name/%s', "tps", check)
275 274
276 -
check_tpsid <- function(x){
275 +
check_tps <- function(x){
277 276
  res <- tp_summary(x)
278 277
  !identical(names(res), "error")
279 278
}
280 279
281 280
#' @export
282 -
#' @rdname get_tpsid
283 -
get_tpsid_ <- function(sci, messages = TRUE, key = NULL, rows = NA,
281 +
#' @rdname get_tps
282 +
get_tps_ <- function(sci, messages = TRUE, key = NULL, rows = NA,
284 283
  sciname = NULL, ...) {
285 284
286 285
  pchk(sciname, "sci")
287 -
  stats::setNames(lapply(sci, get_tpsid_help, messages = messages, key=key,
286 +
  stats::setNames(lapply(sci, get_tps_help, messages = messages, key=key,
288 287
    rows = rows, ...), sci)
289 288
}
289 +
#' @export
290 +
#' @rdname get_tps
291 +
get_tpsid_ <- function(...) {
292 +
  fchk("get_tpsid_", "get_tps_")
293 +
  get_tps_(...)
294 +
}
290 295
291 -
get_tpsid_help <- function(sci, messages, key, rows, ...){
296 +
get_tps_help <- function(sci, messages, key, rows, ...){
292 297
  mssg(messages, "\nRetrieving data for taxon '", sci, "'\n")
293 298
  df <- tp_search(sci=sci, key=key, ...)
294 299
  if("error" %in% names(df)) NULL else sub_rows(df, rows)

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Click to load this diff.
Loading diff...

Learn more Showing 7 files with coverage changes found.

Changes in R/tax_agg.R
-18
+18
Loading file...
Changes in R/zzz.R
-9
+9
Loading file...
New file R/itis_lookup.R
New
Loading file...
New file R/taxize_options.R
New
Loading file...
New file R/taxa_taxon.R
New
Loading file...
Changes in R/progressor.R
-1
+1
Loading file...
Changes in R/get_gbifid.R
-12
+12
Loading file...

77 Commits

Hiding 5 contexual commits
Hiding 1 contexual commits
+3
-3
Hiding 1 contexual commits Hiding 3 contexual commits
+14
+14
Hiding 1 contexual commits Hiding 5 contexual commits
-85
-87
+2
+12
-12
+4
+4
Hiding 48 contexual commits
+2 Files
+231
+260
-29
Files Coverage
R +1.55% 62.58%
Project Totals (131 files) 62.58%
Loading