Skip to content

Commit

Permalink
make sure curl options passed on correctly in classification fxn, bum…
Browse files Browse the repository at this point in the history 
…ped 99
  • Loading branch information
@sckott
sckott committed Jun 11, 2015
1 parent 5d4dd27 commit dd01ab1
Show file tree
Hide file tree
Showing 4 changed files with 53 additions and 46 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ Description: Taxonomic information from around the web. This package
interacts with a suite of web APIs for taxonomic tasks, such
as verifying species names, getting taxonomic hierarchies,
and verifying name spelling.
Version: 0.5.8.9000
Version: 0.5.8.9600
License: MIT + file LICENSE
URL: https://github.com/ropensci/taxize
BugReports: https://github.com/ropensci/taxize/issues
Expand Down
65 changes: 33 additions & 32 deletions R/classification.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -143,15 +143,15 @@ classification.default <- function(x, db = NULL, callopts=list(), return_id = TR
},
ncbi = {
id <- process_ids(x, get_uid, rows = rows, ...)
setNames(classification(id, return_id=return_id, ...), x)
setNames(classification(id, callopts=callopts, return_id=return_id, ...), x)
},
eol = {
id <- process_ids(x, get_eolid, rows = rows, ...)
setNames(classification(id, callopts=callopts, return_id=return_id, ...), x)
},
col = {
id <- process_ids(x, get_colid, rows = rows, ...)
setNames(classification(id, return_id=return_id, ...), x)
setNames(classification(id, callopts=callopts, return_id=return_id, ...), x)
},
tropicos = {
id <- process_ids(x, get_tpsid, rows = rows, ...)
Expand Down Expand Up @@ -182,14 +182,13 @@ process_ids <- function(input, fxn, ...){

#' @export
#' @rdname classification
classification.tsn <- function(id, callopts = list(), return_id = TRUE, ...)
{
fun <- function(x){
classification.tsn <- function(id, callopts = list(), return_id = TRUE, ...) {
fun <- function(x, callopts){
# return NA if NA is supplied
if (is.na(x)) {
out <- NA
} else {
out <- getfullhierarchyfromtsn(x, curlopts = callopts, ...)
out <- getfullhierarchyfromtsn(x, callopts, ...)
# remove overhang
out <- out[1:which(out$tsn == x), c('taxonName', 'rankName', 'tsn')]
names(out) <- c('name', 'rank', 'id')
Expand All @@ -198,23 +197,24 @@ classification.tsn <- function(id, callopts = list(), return_id = TRUE, ...)
return(out)
}
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='itis')
structure(out, class = 'classification', db = 'itis')
}

#' @export
#' @rdname classification
classification.uid <- function(id, return_id = TRUE, ...) {
fun <- function(x){
classification.uid <- function(id, callopts = list(), return_id = TRUE, ...) {
fun <- function(x, callopts){
# return NA if NA is supplied
if(is.na(x)){
if (is.na(x)) {
out <- NA
} else {
baseurl <- "http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=taxonomy"
ID <- paste("ID=", x, sep = "")
searchurl <- paste(baseurl, ID, sep = "&")
tt <- getURL(searchurl)
# tt <- getURL(searchurl)
tt <- GET(searchurl, callopts)
ttp <- xmlTreeParse(tt, useInternalNodes = TRUE)
out <- data.frame(name = xpathSApply(ttp, "//TaxaSet/Taxon/LineageEx/Taxon/ScientificName", xmlValue),
rank = xpathSApply(ttp, "//TaxaSet/Taxon/LineageEx/Taxon/Rank", xmlValue),
Expand All @@ -231,9 +231,9 @@ classification.uid <- function(id, return_id = TRUE, ...) {
Sys.sleep(0.33)
return(out)
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='ncbi')
structure(out, class = 'classification', db = 'ncbi')
}

#' @export
Expand Down Expand Up @@ -272,8 +272,8 @@ classification.eolid <- function(id, key = NULL, callopts = list(), return_id =

#' @export
#' @rdname classification
classification.colid <- function(id, start = NULL, checklist = NULL, return_id = TRUE, ...) {
fun <- function(x){
classification.colid <- function(id, start = NULL, checklist = NULL, callopts = list(), return_id = TRUE, ...) {
fun <- function(x, callopts){
# return NA if NA is supplied
if(is.na(x)){
out <- NA
Expand All @@ -290,8 +290,9 @@ classification.colid <- function(id, start = NULL, checklist = NULL, return_id =
}

args <- compact(list(id = x, response = "full", start = start))
out <- getForm(url, .params = args)
tt <- xmlParse(out)
out <- GET(url, query = args, callopts)
stop_for_status(out)
tt <- xmlParse(content(out, "text"))

out <- data.frame(name = xpathSApply(tt, "//classification//name", xmlValue),
rank = xpathSApply(tt, "//classification//rank", xmlValue),
Expand All @@ -306,15 +307,15 @@ classification.colid <- function(id, start = NULL, checklist = NULL, return_id =
}
return(out)
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='col')
structure(out, class = 'classification', db = 'col')
}

#' @export
#' @rdname classification
classification.tpsid <- function(id, key = NULL, callopts = list(), return_id = TRUE, ...) {
fun <- function(x){
fun <- function(x, callopts){
if(is.na(x)) {
out <- NA
} else {
Expand All @@ -335,19 +336,19 @@ classification.tpsid <- function(id, key = NULL, callopts = list(), return_id =
}
return(out)
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='tropicos')
}

#' @export
#' @rdname classification
classification.gbifid <- function(id, callopts = list(), return_id = TRUE, ...) {
fun <- function(x){
fun <- function(x, callopts){
if(is.na(x)) {
out <- NA
} else {
out <- suppressWarnings(tryCatch(gbif_name_usage(key = x), error=function(e) e))
out <- suppressWarnings(tryCatch(gbif_name_usage(key = x, callopts = callopts), error=function(e) e))
if(is(out, "simpleError")){ NA } else {
nms <- ldply(out[c('kingdom','phylum','class','order','family','genus','species')])
keys <- unname(unlist(out[paste0(c('kingdom','phylum','class','order','family','genus','species'), "Key")]))
Expand All @@ -358,20 +359,20 @@ classification.gbifid <- function(id, callopts = list(), return_id = TRUE, ...)
}
}
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='gbif')
structure(out, class = 'classification', db = 'gbif')
}

#' @export
#' @rdname classification
classification.nbnid <- function(id, callopts = list(), return_id = TRUE, ...) {
fun <- function(x){
if(is.na(x)) {
fun <- function(x, callopts){
if (is.na(x)) {
out <- NA
} else {
out <- suppressWarnings(tryCatch(nbn_classification(id=x, ...), error=function(e) e))
if(is(out, "simpleError")){ NA } else {
out <- suppressWarnings(tryCatch(nbn_classification(id=x, callopts), error=function(e) e))
if (is(out, "simpleError")){ NA } else {
out <- out[ , c('name','rank', 'taxonVersionKey')]
names(out) <- c('name', 'rank', 'id')
# Optionally return id of lineage
Expand All @@ -380,9 +381,9 @@ classification.nbnid <- function(id, callopts = list(), return_id = TRUE, ...) {
}
}
}
out <- lapply(id, fun)
out <- lapply(id, fun, callopts = callopts)
names(out) <- id
structure(out, class='classification', db='nbn')
structure(out, class = 'classification', db = 'nbn')
}

#' @export
Expand Down
28 changes: 17 additions & 11 deletions R/zzz.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -242,14 +242,20 @@ filt <- function(df, rank, z) {
}
}

# filt <- function(df, rank, z) {
# if (!is.null(z)) {
# if (tolower(z) %in% tolower(df[,rank])) {
# df[which(tolower(df[,rank]) %in% tolower(z)), ]
# } else {
# df
# }
# } else {
# df
# }
# }
# failwith replacment ------------------
try_default <- function(expr, default, quiet = FALSE){
result <- default
if (quiet) {
tryCatch(result <- expr, error = function(e) {
})
}
else {
try(result <- expr)
}
result
}

failwith <- function(default = NULL, f, quiet = FALSE){
f <- match.fun(f)
function(...) try_default(f(...), default, quiet = quiet)
}
4 changes: 2 additions & 2 deletions man/classification.Rd
View file
Original file line number Diff line number Diff line change
Expand Up @@ -24,13 +24,13 @@ classification(...)

\method{classification}{tsn}(id, callopts = list(), return_id = TRUE, ...)

\method{classification}{uid}(id, return_id = TRUE, ...)
\method{classification}{uid}(id, callopts = list(), return_id = TRUE, ...)

\method{classification}{eolid}(id, key = NULL, callopts = list(),
return_id = TRUE, ...)

\method{classification}{colid}(id, start = NULL, checklist = NULL,
return_id = TRUE, ...)
callopts = list(), return_id = TRUE, ...)

\method{classification}{tpsid}(id, key = NULL, callopts = list(),
return_id = TRUE, ...)
Expand Down

0 comments on commit dd01ab1

Please sign in to comment.