R/match_names.R

In ropensci/rotl: Interface to the 'Open Tree of Life' API

## internal function that match the arguments provided to the correct
## row number in the data frame representing the Open Tree Taxonomy
## for a series of matched names.
check_args_match_names <- function(response, row_number, taxon_name, ott_id) {
  orig_order <- attr(response, "original_order")
  if (is.null(orig_order)) {
    stop(
      sQuote(substitute(response)), " was not created using ",
      sQuote("tnrs_match_names")
    )
  }

  if (missing(row_number) && missing(taxon_name) && missing(ott_id)) {
    stop(
      "You must specify one of ", sQuote("row_number"),
      sQuote("taxon_name"), " or ", sQuote("ott_id")
    )
  } else if (!missing(row_number) && missing(taxon_name) && missing(ott_id)) {
    if (!is.numeric(row_number)) {
      stop(sQuote("row_number"), " must be a numeric.")
    }
    if (!all(row_number %in% orig_order)) {
      stop(sQuote("row_number"), " is not a valid row number.")
    }
    i <- orig_order[row_number]
  } else if (missing(row_number) && !missing(taxon_name) && missing(ott_id)) {
    if (!is.character(taxon_name)) {
      stop(sQuote("taxon_name"), " must be a character.")
    }
    i <- orig_order[match(tolower(taxon_name), response$search_string)]
    if (any(is.na(i))) {
      stop("Can't find ", taxon_name)
    }
  } else if (missing(row_number) && missing(taxon_name) && !missing(ott_id)) {
    if (!check_numeric(ott_id)) {
      stop(sQuote("ott_id"), " must look like a number.")
    }
    i <- orig_order[match(ott_id, response$ott_id)]
    if (any(is.na(i))) stop("Can't find ", ott_id)
  } else {
    stop(
      "You must use only one of ",
      sQuote("row_number"),
      sQuote("taxon_name"),
      " or ", sQuote("ott_id"), "."
    )
  }

  if (length(i) > 1) {
    stop("You must supply a single element for each argument.")
  }
  i
}

match_row_number <- function(response, row_number, taxon_name, ott_id) {
  ## all the checks on the validity of the arguments are taken care
  ## by check_args_match_names()
  if (missing(row_number) && missing(taxon_name) &&
    missing(ott_id)) {
    stop(
      "You must specify one of ", sQuote("row_number"), " ",
      sQuote("taxon_name"), " ", sQuote("ott_id")
    )
  } else if (!missing(row_number) && (missing(taxon_name) && missing(ott_id))) {
    i <- row_number
  } else if (!missing(taxon_name) && (missing(row_number) && missing(ott_id))) {
    i <- match(tolower(taxon_name), response[["search_string"]])
  } else if (!missing(ott_id) && (missing(row_number) && missing(taxon_name))) {
    i <- match(ott_id, response[["ott_id"]])
  } else {
    stop(
      "You must use only one of ", sQuote("row_number"),
      " ", sQuote("taxon_name"), " ", sQuote("ott_id")
    )
  }
  if (length(i) > 1) {
    stop("You must supply a single element for each argument.")
  }
  i
}

##' Taxonomic names may have different meanings in different taxonomic
##' contexts, as the same genus name can be applied to animals and
##' plants for instance. Additionally, the meaning of a taxonomic name
##' may have change throughout its history, and may have referred to a
##' different taxon in the past. In such cases, a given names might
##' have multiple matches in the Open Tree Taxonomy. These functions
##' allow users to inspect (and update) alternative meaning of a given
##' name and its current taxonomic status according to the Open Tree
##' Taxonomy.
##'
##' To inspect alternative taxonomic meanings of a given name, you
##' need to provide the object resulting from a call to the
##' tnrs_match_names function, as well as one of either the row number
##' corresponding to the name in this object, the name itself (as used
##' in the original query), or the ott_id listed for this name.
##'
##' To update one of the name, you also need to provide the row number
##' in which the name to be replaced appear or its ott id.
##'
##' @title Inspect and Update alternative matches for a name returned
##'     by tnrs_match_names
##' @param response an object generated by the
##'     \code{\link{tnrs_match_names}} function
##' @param row_number the row number corresponding to the name to
##'     inspect
##' @param taxon_name the taxon name corresponding to the name to
##'     inspect
##' @param ott_id the ott id corresponding to the name to inspect
##' @param ... currently ignored
##' @return a data frame
##' @seealso \code{\link{tnrs_match_names}}
##' @examples
##'   \dontrun{
##'    matched_names <- tnrs_match_names(c("holothuria", "diadema", "boletus"))
##'    inspect(matched_names, taxon_name="diadema")
##'    new_matched_names <- update(matched_names, taxon_name="diadema",
##'                                new_ott_id = 631176)
##'    new_matched_names
##'    }
##' @export
##' @rdname match_names
inspect.match_names <- function(response, row_number, taxon_name, ott_id, ...) {
  i <- check_args_match_names(response, row_number, taxon_name, ott_id)
  j <- match_row_number(response, row_number, taxon_name, ott_id)

  if (attr(response, "has_original_match")[j]) {
    res <- attr(response, "original_response")
    summary_match <- build_summary_match(res,
      res_id = i, match_id = NULL,
      initial_creation = FALSE
    )
  } else {
    summary_match <- response[j, ]
  }
  clean_tnrs_summary(summary_match)
}

##' @export
##' @rdname match_names
inspect <- function(response, ...) UseMethod("inspect")

##' @param object an object created by \code{\link{tnrs_match_names}}
##' @param new_row_number the row number in the output of
##'     \code{\link{inspect}} to replace the taxa specified by
##'     \code{row_number}, \code{taxon_name}, or \code{ott_id}.
##' @param new_ott_id the ott id of the taxon to replace the taxa
##'     specified by \code{row_number}, \code{taxon_name}, or
##'     \code{ott_id}.
##' @export
##' @rdname match_names
##' @importFrom stats update
update.match_names <- function(object, row_number, taxon_name, ott_id,
                               new_row_number, new_ott_id, ...) {
  response <- object
  i <- check_args_match_names(response, row_number, taxon_name, ott_id)
  j <- match_row_number(response, row_number, taxon_name, ott_id)

  res <- attr(response, "original_response")

  if (!attr(response, "has_original_match")[j]) {
    warning(
      "There is no match for this name, ",
      "so there is nothing to replace it with."
    )
    return(response)
  }

  tmpRes <- res$results[[i]]

  if (missing(row_number)) {
    if (!missing(taxon_name)) {
      rnb <- match(tolower(taxon_name), response$search_string)
    } else if (!missing(ott_id)) {
      rnb <- match(ott_id, response$ott_id)
    }
  } else {
    rnb <- row_number
  }

  if (missing(new_row_number) && missing(new_ott_id)) {
    stop(
      "You must specify either ", sQuote("new_row_number"),
      " or ", sQuote("new_ott_id")
    )
  } else if (!missing(new_row_number) && missing(new_ott_id)) {
    if (!new_row_number %in% seq_len(length(tmpRes$matches))) {
      stop(sQuote("new_row_number"), " is not a valid row number.")
    }
    j <- new_row_number
  } else if (missing(new_row_number) && !missing(new_ott_id)) {
    all_ott_id <- sapply(
      lapply(
        tmpRes[["matches"]],
        function(x) x[["taxon"]]
      ),
      function(x) .tax_ott_id(x)
    )
    j <- match(new_ott_id, all_ott_id)
    if (any(is.na(j))) stop("Can't find ", new_ott_id)
  } else {
    stop(
      "You must use only one of ", sQuote("new_row_number"),
      " or ", sQuote("new_ott_id")
    )
  }
  if (length(j) > 1) stop("You must supply a single element for each argument")

  summ_match <- summary_row_factory(res, res_id = i, match_id = j)

  response[rnb, ] <- summ_match
  attr(response, "match_id")[rnb] <- j
  clean_tnrs_summary(response)
}


## Access the elements for a given match:
## is_synonym, score, nomenclature_code, is_approximate_match, taxon
get_list_element <- function(response, i, list_name) {
  list_content <- lapply(
    response[["results"]][[i]][["matches"]],
    function(x) {
      x[[list_name]]
    }
  )
  list_content
}

match_names_method_factory <- function(list_name) {
  function(tax, row_number, taxon_name, ott_id, ...) {
    response <- tax
    res <- attr(response, "original_response")

    no_args <- all(c(
      missing(row_number), missing(taxon_name),
      missing(ott_id)
    ))

    if (no_args) {
      res_i <- attr(response, "original_order")[attr(response, "has_original_match")]
      ret <- lapply(res_i, function(i) {
        get_list_element(res, i, list_name)
      })
      names(ret) <- sapply(res_i, function(i) {
        get_list_element(res, i, "matched_name")[[1]]
      })
      ## ret is already in the correct order so we can use a sequence
      ## to extract the correct element
      ret <- mapply(function(x, i) {
        ret[[x]][i]
      }, seq_along(ret), attr(response, "match_id")[attr(response, "has_original_match")])
      if (all(sapply(ret, length) == 1)) {
        ret <- unlist(ret, use.names = TRUE)
      }
    } else {
      i <- check_args_match_names(response, row_number, taxon_name, ott_id)
      j <- match_row_number(response, row_number, taxon_name, ott_id)
      if (attr(response, "has_original_match")[j]) {
        ret <- get_list_element(res, i, list_name)[attr(response, "match_id")[j]]
      } else {
        ret <- list(
          ott_id = NA_character_,
          name = response[["search_string"]][j],
          unique_name = NA_character_,
          rank = NA_character_,
          tax_sources = NA_character_,
          flags = NA_character_,
          synonyms = NA_character_,
          is_suppressed = NA_character_
        )
        ret <- list(ret)
      }
    }

    ret
  }
}

match_names_taxon_method_factory <- function(.f) {
  function(tax, row_number, taxon_name, ott_id, ...) {
    extract_tax_list <- match_names_method_factory("taxon")
    tax_info <- extract_tax_list(tax,
      row_number = row_number,
      taxon_name = taxon_name,
      ott_id = ott_id
    )
    res <- lapply(tax_info, function(x) .f(x))
    names(res) <- vapply(tax_info, function(x) .tax_unique_name(x), character(1))
    res <- add_otl_class(res, .f)
    res
  }
}

##' \code{rotl} provides a collection of functions that allows users
##' to extract relevant information from an object generated by
##' \code{\link{tnrs_match_names}} function.
##'
##' These methods optionally accept one of the arguments
##' \code{row_number}, \code{taxon_name} or \code{ott_id} to retrieve
##' the corresponding information for one of the matches in the object
##' returned by the \code{\link{tnrs_match_names}} function.
##'
##' If these arguments are not provided, these methods can return
##' information for the matches currently listed in the object
##' returned by \code{\link{tnrs_match_names}}.
##'
##' @title \code{ott_id} and \code{flags} for taxonomic names matched
##'     by \code{tnrs_match_names}
##' @param tax an object returned by \code{\link{tnrs_match_names}}
##' @param row_number the row number corresponding to the name for
##'     which to list the synonyms
##' @param taxon_name the taxon name corresponding to the name for
##'     which to list the synonyms
##' @param ott_id the ott id corresponding to the name for which to
##'     list the synonyms
##' @param ... currently ignored
##' @return A list of the ott ids or flags for the taxonomic names
##'     matched with \code{\link{tnrs_match_names}}, for either one or
##'     all the names.
##' @examples
##' \dontrun{
##'   rsp <- tnrs_match_names(c("Diadema", "Tyrannosaurus"))
##'   rsp$ott_id    # ott id for match currently in use
##'   ott_id(rsp)   # similar as above but elements are named
##'
##'   ## flags() is useful for instance to determine if a taxon is extinct
##'   flags(rsp, taxon_name="Tyrannosaurus")
##' }
##' @export
##' @rdname match_names-methods
ott_id.match_names <- match_names_taxon_method_factory(.tax_ott_id)


##' @export
##' @rdname match_names-methods
flags.match_names <- match_names_taxon_method_factory(.tax_flags)

##' When querying the Taxonomic Name Resolution Services for a
##' particular taxonomic name, the API returns as possible matches all
##' names that include the queried name as a possible synonym. This
##' function allows you to explore other synonyms for an accepted
##' name, and allows you to determine why the name you queried is
##' returning an accepted synonym.
##'
##' To list synonyms for a given taxonomic name, you need to provide
##' the object resulting from a call to the
##' \code{\link{tnrs_match_names}} function, as well as one of either
##' the row number corresponding to the name in this object, the name
##' itself (as used in the original query), or the ott_id listed for
##' this name. Otherwise, the synonyms for all the currently matched
##' names are returned.
##'
##' @title List the synonyms for a given name
##' @param tax a data frame generated by the
##'     \code{\link{tnrs_match_names}} function
##' @param row_number the row number corresponding to the name for
##'     which to list the synonyms
##' @param taxon_name the taxon name corresponding to the name for
##'     which to list the synonyms
##' @param ott_id the ott id corresponding to the name for which to
##'     list the synonyms
##' @param ... currently ignored
##' @return a list whose elements are all synonym names (as vectors of
##'     character) for the taxonomic names that match the query (the
##'     names of the elements of the list).
##' @examples
##' \dontrun{
##'    echino <- tnrs_match_names(c("Diadema", "Acanthaster", "Fromia"))
##'    ## These 3 calls are identical
##'    synonyms(echino, taxon_name="Acanthaster")
##'    synonyms(echino, row_number=2)
##'    synonyms(echino, ott_id=337928)
##' }
##' @export
synonyms.match_names <- match_names_taxon_method_factory(.tax_synonyms)

##' @export
tax_sources.match_names <- match_names_taxon_method_factory(.tax_sources)

##' @export
tax_rank.match_names <- match_names_taxon_method_factory(.tax_rank)


##' @export
is_suppressed.match_names <- match_names_taxon_method_factory(.tax_is_suppressed)


##' @export
unique_name.match_names <- match_names_taxon_method_factory(.tax_unique_name)


##' @export
tax_name.match_names <- match_names_taxon_method_factory(.tax_name)