Commit e16ea386 authored by Eric Coissac's avatar Eric Coissac

Implementation of several taxonomy related functions

parent 16748248
......@@ -31,6 +31,7 @@ Collate:
'robiobject.R'
'dplyr.R'
'dplyr_robimetabar.R'
'ecotag.R'
'entropie.R'
'lowest_common_ancestor.R'
'metabar_data_class.R'
......
......@@ -75,7 +75,8 @@ S3method(dim,robitaxonomy)
S3method(dimnames,robidata)
S3method(dimnames,robimetabar)
S3method(ecofind,robitaxonomy)
S3method(expand_names,robitaxonomy)
S3method(ecotag_best_identity,robimetabar)
S3method(ecotag_best_identity,robimotu)
S3method(format,robicategory)
S3method(forward_tags,default)
S3method(forward_tags,robimetabar)
......@@ -87,6 +88,11 @@ S3method(ids,default)
S3method(ids,robidata)
S3method(ids_colname,robidata)
S3method(is_full_taxonomy,robitaxonomy)
S3method(is_subcladeof,numeric)
S3method(is_subcladeof,robimetabar)
S3method(is_subcladeof,robimotu)
S3method(is_subcladeof,robitaxid)
S3method(is_subcladeof,tbl)
S3method(left_parse_sample_ids,robimetabar)
S3method(left_parse_sample_ids,robisample)
S3method(lowest_common_ancestor,robitaxonomy)
......@@ -94,7 +100,7 @@ S3method(master_taxids,default)
S3method(master_taxids,robimetabar)
S3method(master_taxids,robimotu)
S3method(master_taxids_colname,robimetabar)
S3method(master_taxids_colname,robimotu)
S3method(master_taxids_colname,tbl)
S3method(max,robitaxonomy)
S3method(min,robitaxonomy)
S3method(motus,robimetabar)
......@@ -105,7 +111,6 @@ S3method(names,robiseq)
S3method(nmotus,robimetabar)
S3method(nodes,robitaxonomy)
S3method(nsamples,robimetabar)
S3method(parent,robitaxonomy)
S3method(pillar_shaft,robicategory)
S3method(pillar_shaft,robitag)
S3method(pillar_shaft,robitaxid)
......@@ -130,7 +135,11 @@ S3method(right_parse_sample_ids,robisample)
S3method(samples,robimetabar)
S3method(samples_ids,robimetabar)
S3method(samples_ids_colname,robimetabar)
S3method(scientific_name,robitaxonomy)
S3method(scientific_name,numeric)
S3method(scientific_name,robimetabar)
S3method(scientific_name,robimotu)
S3method(scientific_name,robitaxid)
S3method(scientific_name,tbl)
S3method(set_motus,data.frame)
S3method(set_motus,robimotu)
S3method(set_samples,robisample)
......@@ -145,7 +154,16 @@ S3method(taxids,default)
S3method(taxids,robimetabar)
S3method(taxids,robimotu)
S3method(taxids_colname,robimetabar)
S3method(taxids_colname,robimotu)
S3method(taxids_colname,tbl)
S3method(taxonomic_parent,numeric)
S3method(taxonomic_parent,robimotu)
S3method(taxonomic_parent,robitaxid)
S3method(taxonomic_parent,tbl)
S3method(taxonomic_rank,numeric)
S3method(taxonomic_rank,robimetabar)
S3method(taxonomic_rank,robimotu)
S3method(taxonomic_rank,robitaxid)
S3method(taxonomic_rank,tbl)
S3method(type_sum,robicategory)
S3method(type_sum,robilca)
S3method(type_sum,robipath)
......@@ -198,6 +216,7 @@ export(dd_exp_q)
export(decostand)
export(download_ncbi_taxdump)
export(ecofind)
export(ecotag_best_identity)
export(every_oligo)
export(exp_q)
export(expand_names)
......@@ -263,7 +282,7 @@ export(nmotus)
export(nodes)
export(nsamples)
export(nuc2int)
export(parent)
export(parent.robitaxonomy)
export(plot_read_x_motus)
export(rainbow_tol)
export(rank.list)
......@@ -315,6 +334,7 @@ export(set_motus)
export(set_sample.data.frame)
export(set_samples)
export(species)
export(spread_names.robitaxonomy)
export(superkingdom)
export(tags)
export(tags_colname)
......@@ -324,7 +344,8 @@ export(taxids)
export(taxids_colname)
export(taxon.at.rank)
export(taxon.path)
export(taxonomic.rank)
export(taxonomic_parent)
export(taxonomic_rank)
export(unclass_robiobject)
export(validate_object)
export(validate_robimetabar)
......
......@@ -35,7 +35,7 @@ plot_read_x_motus <- function(metabar,mapping = NULL,
left_join(metabar %>% samples_read_count(),
metabar %>% samples_motu_count(),
by = sids) %>%
left_join(samples(metabar), by = sids) %>% print() %>%
left_join(samples(metabar), by = sids) %>%
ggplot(aes(x=read_count,
y=motu_count,
col=get(cats))) +
......
#' Extracts best ecotag identification from metabar results
#'
#' @param object
#' @param taxonomy
#'
#' @return
#' @export
#'
#' @examples
ecotag_best_identity <- function(object,taxonomy) {
UseMethod("ecotag_best_identity",object)
}
#' @rdname ecotag_best_identity
#' @export
ecotag_best_identity.robimotu <- function(object,taxonomy) {
mids <- ids_colname(object)
object$best_identity %>%
cbind(ids(object)) %>%
gather(key = "db",value = "identity", -all_of(mids)) %>%
group_by_at(mids) %>%
mutate(rank__ = rank(identity)) %>%
filter(rank__ <= 1) %>%
select(-rank__) %>% left_join(
object$best_match %>%
cbind(ids(object)) %>%
gather(key = "db",value = "entry", -all_of(mids)),
by = c(mids,"db")
) %>% left_join(
object$taxid_by_db %>%
cbind(ids(object)) %>%
gather(key = "db",value = "taxid", -all_of(mids)),
by = c(mids,"db")
) %>%
ungroup() -> e
e$taxid <- as_robitaxid_master(e$taxid)
robimotu(e)
}
#' @rdname ecotag_best_identity
#' @export
ecotag_best_identity.robimetabar <- function(object,taxonomy) {
motus(object) %>% ecotag_best_identity(taxonomy)
}
\ No newline at end of file
......@@ -46,6 +46,13 @@ features_as_tibble <- function(features) {
#'
#' @examples
feature_as_matrix <- function(feature,na_value=NA) {
feature <- lapply(feature,
function(x) {
y <-as.character(x)
names(y)<-names(x)
y}
)
all_names <- sort(unique(unlist(lapply(feature, names))))
data <- do.call(rbind,lapply(feature, function(x) x[all_names]))
......@@ -54,7 +61,7 @@ feature_as_matrix <- function(feature,na_value=NA) {
colnames(data) <- all_names
data
as_tibble(data) %>% lapply(.coerce_vector) %>% as_tibble()
}
feature_as_three_columns <- function(feature,motus_ids=NULL) {
......@@ -76,12 +83,6 @@ feature_as_three_columns <- function(feature,motus_ids=NULL) {
.coerce_vector <- function(data) {
if (is_list(data) &&
all(vapply(data,is_list,TRUE)) &&
all(vapply(data,length,0) <= 1))
data = sapply(data,
function(x) if (length(x) == 0) NA else x[[1]])
data[data == "None"] <- NA
converted <- suppressWarnings(as.logical(data))
......@@ -194,13 +195,6 @@ read_obifasta <- function(file,
length(mfasta[[1]])))
if (.has_doParallel && getDoParRegistered()) {
`%dp%` <- `%dopar%`
}
else{
`%dp%` <- `%do%`
}
pbar <- progress_estimated(n = length(mfasta[[1]]),
min_time = 5)
......
......@@ -10,7 +10,7 @@
#'
NULL
.robimetabar = R6Class("robimetabar",
.robimetabar = R6::R6Class("robimetabar",
public = list(
data = NULL,
......
......@@ -280,7 +280,7 @@ taxids.default <- function(object) {
#' s <- robimotu(n=4)
#' taxids_colname(s)
#'
taxids_colname.robimotu <- function(object) {
taxids_colname.tbl <- function(object) {
colnames(object)[which(vapply(object, is_robitaxid, FUN.VALUE = TRUE))]
}
......@@ -333,10 +333,18 @@ master_taxids.default <- function(object) {
#' s <- robimotu(n=4)
#' master_taxids_colname(s)
#'
master_taxids_colname.robimotu <- function(object) {
master_taxids_colname.tbl <- function(object) {
colnames(object)[which(vapply(object, is,
FUN.VALUE = TRUE,
class2 = "robitaxid_master"))]
class2 = "robitaxid_master"))] -> response
if (length(response) == 0) {
rescue = taxids_colname(object)
if (length(rescue) == 1)
response = rescue
}
response
}
#' @rdname taxids
......
......@@ -233,7 +233,7 @@ as_robitaxid_master.default = function(object) {
as_robitaxid_master.robitaxid = function(object) {
classes <- class(object)
rclass <- which(classes == 'robitaxid')
class(object) <- c("robitaxid_forward",classes[rclass:length(classes)])
class(object) <- c("robitaxid_master",classes[rclass:length(classes)])
object
}
......
......@@ -112,8 +112,21 @@ ecofind = function(taxonomy,patterns,
#'
#' @author Eric Coissac
#' @export
scientific_name = function(taxonomy) {
UseMethod("scientific_name", taxonomy)
scientific_name = function(data,taxonomy,results_in,...) {
UseMethod("scientific_name", data)
}
#' Returns the taxonomic rank associated to a taxid
#'
#' @param taxonomy an object able to provide a taxonomy.
#' @param data a vector of taxid to analyse
#'
#' @return a vector of type \code{character} containing the taxonomic ranks
#'
#' @author Eric Coissac
#' @export
taxonomic_rank = function(data,taxonomy,results_in,...) {
UseMethod("taxonomic_rank", data)
}
......@@ -140,10 +153,18 @@ scientific_name = function(taxonomy) {
#'
#' @author Eric Coissac
#' @export
parent = function(taxonomy) {
UseMethod("parent", taxonomy)
taxonomic_parent = function(data,taxonomy, with_name = TRUE, results_in,...) {
UseMethod("taxonomic_parent", data)
}
#'
#' @author Eric Coissac
#' @export
is_subcladeof = function(data, taxonomy, parent, results_in, ...) {
UseMethod("is_subcladeof", data)
}
#' @author Eric Coissac
#' @export
expand_names <- function(taxonomy) {
......@@ -182,12 +203,6 @@ taxon.path = function(taxonomy,taxid,
UseMethod("taxon.path", taxonomy)
}
#'
#' @author Eric Coissac
#' @export
is_subcladeof = function(taxonomy,taxid,parent,na.rm=TRUE,drop=TRUE) {
UseMethod("is.subcladeof", taxonomy)
}
#' Computes the lowest common ancestor in the taxonomy tree between a set of taxa
#'
......@@ -242,18 +257,6 @@ rank.list = function(taxonomy) {
UseMethod("rank.list", taxonomy)
}
#' Returns the taxonomic rank associated to a taxid
#'
#' @param taxonomy an object able to provide a taxonomy.
#' @param taxid a vector of taxid to analyse
#'
#' @return a vector of type \code{character} containing the taxonomic ranks
#'
#' @author Eric Coissac
#' @export
taxonomic.rank = function(taxonomy,taxid,na.rm=TRUE) {
UseMethod("taxonomic.rank", taxonomy)
}
#' Extracts the taxid at a specified taxonomic rank.
#'
......
......@@ -212,12 +212,275 @@ ecofind.robitaxonomy = function(taxonomy,patterns,
#' @rdname scientific_name
#' @export
scientific_name.robitaxonomy <- function(taxonomy) {
scn <- nodes(taxonomy)$scientific_name
names(scn) <- taxonomy$taxid
scn
scientific_name.robitaxid <- function(data,taxonomy,results_in) {
if (missing(results_in))
results_in = "scientific_name"
tibble(taxid = as_robitaxid_master(data)) %>%
left_join(nodes(taxonomy) %>%
select(taxid,!! results_in := scientific_name),
by = "taxid")
}
#' @rdname scientific_name
#' @export
scientific_name.numeric <- function(data,taxonomy,results_in) {
fcall <- match.call()
fcall[[1]] = quote(scientific_name)
fcall[[2]] = quote(as_robitaxid_master(data))
eval(fcall)
}
#' @rdname scientific_name
#' @export
scientific_name.tbl <- function(data,taxonomy,results_in,slot) {
if (missing(results_in))
results_in = "scientific_name"
if (missing(slot))
slot = master_taxids_colname(data)
bys <- "taxid"
names(bys) <- slot
suppressWarnings(
data %>% left_join(data %>%
pull(slot)%>%
unique() %>% na.omit() %>%
as_robitaxid_master() %>%
scientific_name(taxonomy, results_in), by = bys))
}
#' @rdname scientific_name
#' @export
scientific_name.robimotu <- function(data,taxonomy,results_in,slot) {
fcall <- match.call()
fcall[[1]] = quote(scientific_name)
fcall[[2]] = quote(as_tibble(data))
eval(fcall) %>%
as_robimotu()
}
#' @rdname scientific_name
#' @export
scientific_name.robimetabar <- function(data,taxonomy,results_in,slot) {
fcall = match.call()
fcall[[1]] = quote(scientific_name)
fcall[[2]] = quote(motus(data))
eval(fcall)
}
#' @rdname taxonomic_rank
#' @export
taxonomic_rank.robitaxid <- function(data,taxonomy,results_in) {
if (missing(results_in))
results_in = "rank"
tibble(taxid = as_robitaxid_master(data)) %>%
left_join(nodes(taxonomy) %>%
select(taxid,!! results_in := rank),
by = "taxid")
}
#' @rdname taxonomic_rank
#' @export
taxonomic_rank.numeric <- function(data,taxonomy,results_in) {
fcall <- match.call()
fcall[[1]] = quote(taxonomic_rank)
fcall[[2]] = quote(as_robitaxid_master(data))
eval(fcall)
}
#' @rdname taxonomic_rank
#' @export
taxonomic_rank.tbl <- function(data,taxonomy,results_in,slot) {
if (missing(results_in))
results_in = "rank"
if (missing(slot))
slot = master_taxids_colname(data)
bys <- "taxid"
names(bys) <- slot
suppressWarnings(
data %>% left_join(data %>%
pull(slot)%>%
unique() %>% na.omit %>%
as_robitaxid_master() %>%
taxonomic_rank(taxonomy,results_in), by = bys))
}
#' @rdname taxonomic_rank
#' @export
taxonomic_rank.robimotu <- function(data,taxonomy,results_in,slot) {
fcall <- match.call()
fcall[[1]] = quote(taxonomic_rank)
fcall[[2]] = quote(as_tibble(data))
eval(fcall) %>%
as_robimotu()
}
#' @rdname taxonomic_rank
#' @export
taxonomic_rank.robimetabar <- function(data,taxonomy,results_in,slot) {
fcall = match.call()
fcall[[1]] = quote(taxonomic_rank)
fcall[[2]] = quote(motus(data))
eval(fcall)
}
#' @rdname taxonomic_parent
#' @export
taxonomic_parent.robitaxid = function(data,taxonomy, with_name = TRUE, results_in) {
if (missing(results_in)) {
results_in = "parent"
}
bys <- "taxid"
names(bys) <- results_in
tibble(taxid = as_robitaxid_master(data)) %>%
left_join(nodes(taxonomy) %>%
select(taxid,!! results_in := parent),
by = "taxid") -> results
if (with_name)
results %>% left_join(results %>%
pull(results_in) %>%
unique() %>% na.omit() %>%
as_robitaxid_master() %>%
scientific_name(taxonomy,
results_in = paste0(results_in,"_name")),
by = bys) -> results
results
}
#' @rdname taxonomic_parent
#' @export
taxonomic_parent.numeric <- function(data,taxonomy, with_name = TRUE, results_in) {
fcall <- match.call()
fcall[[1]] = quote(taxonomic_parent)
fcall[[2]] = quote(as_robitaxid_master(data))
eval(fcall)
}
#' @rdname taxonomic_parent
#' @export
taxonomic_parent.tbl <- function(data,taxonomy, with_name = TRUE,results_in,slot) {
if (missing(results_in))
results_in = "parent"
if (missing(slot))
slot = master_taxids_colname(data)
bys <- "taxid"
names(bys) <- slot
suppressWarnings(
data %>% left_join(data %>%
pull(slot)%>%
unique() %>% na.omit() %>%
as_robitaxid_master() %>%
taxonomic_parent(taxonomy,with_name,results_in), by = bys))
}
#' @rdname taxonomic_parent
#' @export
taxonomic_parent.robimotu <- function(data,taxonomy, with_name = TRUE,results_in,slot) {
fcall <- match.call()
fcall[[1]] = quote(taxonomic_parent)
fcall[[2]] = quote(as_tibble(data))
eval(fcall) %>%
as_robimotu()
}
#' @rdname taxonomic_parent
#' @export
taxonomic_rank.robimetabar <- function(data,taxonomy, with_name = TRUE,results_in,slot) {
fcall = match.call()
fcall[[1]] = quote(taxonomic_parent)
fcall[[2]] = quote(motus(data))
eval(fcall)
}
#' @rdname is_subcladeof
#' @export
is_subcladeof.robitaxid = function(data, taxonomy,parent,results_in) {
if (missing(results_in)) {
results_in = paste0("is_",
make.names(scientific_name(parent,
taxonomy) %>%
pull(scientific_name)))
}
bys <- "taxid"
names(bys) <- results_in
tibble(taxid = as_robitaxid_master(data)) %>%
left_join(nodes(taxonomy) %>%
select(taxid,path),
by = "taxid") %>%
mutate(!! results_in := vapply(path, function(i) parent %in% i, TRUE) |
taxid == parent) %>%
select(-path)
}
#' @rdname is_subcladeof
#' @export
is_subcladeof.numeric <- function(data, taxonomy,parent,results_in) {
fcall <- match.call()
fcall[[1]] = quote(is_subcladeof)
fcall[[2]] = quote(as_robitaxid_master(data))
eval(fcall)
}
#' @rdname is_subcladeof
#' @export
is_subcladeof.tbl <- function(data, taxonomy,parent,results_in,slot) {
if (missing(results_in)) {
results_in = paste0("is_",
make.names(scientific_name(parent,
taxonomy) %>%
pull(scientific_name)))
}
if (missing(slot))
slot = master_taxids_colname(data)
bys <- "taxid"
names(bys) <- slot
suppressWarnings(
data %>% left_join(data %>%
pull(slot)%>%
unique() %>% na.omit() %>%
as_robitaxid_master() %>%
is_subcladeof(taxonomy,parent,results_in), by = bys))
}
#' @rdname is_subcladeof
#' @export
is_subcladeof.robimotu <- function(data, taxonomy,parent,results_in,slot) {
fcall <- match.call()
fcall[[1]] = quote(is_subcladeof)
fcall[[2]] = quote(as_tibble(data))
eval(fcall) %>%
as_robimotu()
}
#' @rdname is_subcladeof
#' @export
is_subcladeof.robimetabar <- function(data, taxonomy,parent,results_in,slot) {
fcall = match.call()
fcall[[1]] = quote(is_subcladeof)
fcall[[2]] = quote(motus(data))
eval(fcall)
}
#' @rdname as_robitaxid
#' @export
as_robitaxid.robitaxonomy <- function(x) {
......@@ -234,7 +497,6 @@ as_robitaxid_master.robitaxonomy <- function(x) {
taxids
}
#' @rdname parent
#' @export
parent.robitaxonomy = function(taxonomy) {
reference <- reference_taxonomy(taxonomy)
......@@ -315,7 +577,7 @@ min.robitaxonomy <- function(x,..., na.rm = FALSE) {
}
#' @export
expand_names.robitaxonomy <- function(taxonomy) {
spread_names.robitaxonomy <- function(taxonomy) {
suppressWarnings(nodes(taxonomy) %>%
dplyr::left_join(alternative_names(taxonomy),
by = "taxid")) %>%
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/ecotag.R
\name{ecotag_best_identity}
\alias{ecotag_best_identity}
\alias{ecotag_best_identity.robimotu}
\alias{ecotag_best_identity.robimetabar}
\title{Extracts best ecotag identification from metabar results}
\usage{
ecotag_best_identity(object, taxonomy)
\method{ecotag_best_identity}{robimotu}(object, taxonomy)
\method{ecotag_best_identity}{robimetabar}(object, taxonomy)
}
\arguments{
\item{taxonomy}{}
}
\value{
}
\description{
Extracts best ecotag identification from metabar results
}
......@@ -2,12 +2,24 @@
% Please edit documentation in R/taxonomy_methods.R, R/taxonomy_robi.R
\name{scientific_name}
\alias{scientific_name}
\alias{scientific_name.robitaxonomy}
\alias{scientific_name.robitaxid}
\alias{scientific_name.numeric}
\alias{scientific_name.tbl}
\alias{scientific_name.robimotu}
\alias{scientific_name.robimetabar}
\title{Returns the scientific name corresponding to a \emph{NCBI taxid}}
\usage{
scientific_name(taxonomy)
scientific_name(data, taxonomy, results_in, ...)
\method{scientific_name}{robitaxonomy}(taxonomy)
\method{scientific_name}{robitaxid}(data, taxonomy, results_in)
\method{scientific_name}{numeric}(data, taxonomy, results_in)
\method{scientific_name}{tbl}(data, taxonomy, results_in, slot)
\method{scientific_name}{robimotu}(data, taxonomy, results_in, slot)
\method{scientific_name}{robimetabar}(data, taxonomy, results_in, slot)
}
\arguments{
\item{taxonomy}{an object able to provide a taxonomy.}
......
......@@ -4,12 +4,12 @@
\alias{taxids}
\alias{taxids_colname}
\alias{taxids.default}
\alias{taxids_colname.robimotu}
\alias{taxids_colname.tbl}
\alias{taxids.robimotu}
\alias{master_taxids}
\alias{master_taxids_colname}
\alias{master_taxids.default}
\alias{master_taxids_colname.robimotu}
\alias{master_taxids_colname.tbl}
\alias{master_taxids.robimotu}
\alias{taxids_colname.robimetabar}
\alias{master_taxids_colname.robimetabar}
......@@ -23,7 +23,7 @@ taxids_colname(object)
\method{taxids}{default}(object)
\method{taxids_colname}{robimotu}(object)
\method{taxids_colname}{tbl}(object)
\method{taxids}{robimotu}(object)
......@@ -33,7 +33,7 @@ master_taxids_colname(object)
\method{master_taxids}{default}(object)
\method{master_taxids_colname}{robimotu}(object)
\method{master_taxids_colname}{tbl}(object)
\method{master_taxids}{robimotu}(object)
......
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/taxonomy_methods.R, R/taxonomy_robi.R
\name{parent}
\alias{parent}
\alias{parent.robitaxonomy}
\name{taxonomic_parent}
\alias{taxonomic_parent}
\alias{taxonomic_parent.robitaxid}
\alias{taxonomic_parent.numeric}
\alias{taxonomic_parent.tbl}
\alias{taxonomic_parent.robimotu}
\alias{taxonomic_rank.robimetabar}