Commit 6e719b68 authored by Eric Coissac's avatar Eric Coissac

A lot of bugs

parent 851463d6
......@@ -12,6 +12,7 @@ LazyData: true
RoxygenNote: 7.1.0
VignetteBuilder: knitr
Imports: R6,
vctrs,
tidyverse,
ore,
Rdpack,
......@@ -43,6 +44,7 @@ Collate:
'read_obifasta.R'
'read_metabar.R'
'robidata.R'
'robiatomic.R'
'robitaxid.R'
'robitag.R'
'robiuniqueid.R'
......
......@@ -3,27 +3,15 @@
S3method("$",robiseq)
S3method("$<-",robimotu)
S3method("$<-",robisample)
S3method("[",robicategory)
S3method("[",robiatomic)
S3method("[",robiseq)
S3method("[",robiseq_db)
S3method("[",robitag)
S3method("[",robitag_forward)
S3method("[",robitag_reverse)
S3method("[",robitaxid)
S3method("[",robitaxid_master)
S3method("[",robiuniqueid)
S3method("[<-",robicategory)
S3method("[<-",robitag)
S3method("[<-",robitag_forward)
S3method("[<-",robitag_reverse)
S3method("[<-",robitaxid)
S3method("[<-",robitaxid_master)
S3method("[<-",robiuniqueid)
S3method("[<-",robiatomic)
S3method("[[",robiseq)
S3method("[[<-",robimotu)
S3method("[[<-",robisample)
S3method(alternative_names,robitaxonomy)
S3method(alternative_taxids,robitaxonomy)
S3method(as_robiatomic,default)
S3method(as_robiatomic,robiatomic)
S3method(as_robicategory,character)
S3method(as_robicategory,default)
S3method(as_robicategory,factor)
......@@ -47,21 +35,13 @@ S3method(as_robitag_reverse,default)
S3method(as_robitag_reverse,robitag)
S3method(as_robitaxid,default)
S3method(as_robitaxid,robitaxid)
S3method(as_robitaxid,robitaxonomy)
S3method(as_robitaxid_master,default)
S3method(as_robitaxid_master,robitaxid)
S3method(as_robitaxid_master,robitaxonomy)
S3method(as_robitaxonomy,robilca)
S3method(as_robiuniqueid,character)
S3method(as_robiuniqueid,default)
S3method(as_robiuniqueid,robiuniqueid)
S3method(c,robicategory)
S3method(c,robitag)
S3method(c,robitag_forward)
S3method(c,robitag_reverse)
S3method(c,robitaxid)
S3method(c,robitaxid_master)
S3method(c,robiuniqueid)
S3method(c,robiatomic)
S3method(categories,default)
S3method(categories,robimetabar)
S3method(categories,robisample)
......@@ -71,7 +51,6 @@ S3method(decostand,"NULL")
S3method(decostand,default)
S3method(decostand,robimetabar)
S3method(dim,robimetabar)
S3method(dim,robitaxonomy)
S3method(dimnames,robidata)
S3method(dimnames,robimetabar)
S3method(ecofind,robitaxonomy)
......@@ -83,48 +62,37 @@ S3method(forward_tags,robimetabar)
S3method(forward_tags,robisample)
S3method(forward_tags_colname,robimetabar)
S3method(forward_tags_colname,robisample)
S3method(full_taxonomy,robitaxonomy)
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,robidata)
S3method(left_parse_sample_ids,robimetabar)
S3method(left_parse_sample_ids,robisample)
S3method(lowest_common_ancestor,robitaxonomy)
S3method(master_taxids,default)
S3method(master_taxids,robimetabar)
S3method(master_taxids,robimotu)
S3method(master_taxids_colname,robimetabar)
S3method(master_taxids_colname,tbl)
S3method(max,robitaxonomy)
S3method(min,robitaxonomy)
S3method(motus,robimetabar)
S3method(motus_ids,robimetabar)
S3method(motus_ids_colname,robimetabar)
S3method(names,robimetabar)
S3method(names,robiseq)
S3method(nmotus,robimetabar)
S3method(nodes,robitaxonomy)
S3method(nsamples,robimetabar)
S3method(pillar_shaft,robicategory)
S3method(pillar_shaft,robitag)
S3method(pillar_shaft,robitaxid)
S3method(pillar_shaft,robiuniqueid)
S3method(print,robicategory)
S3method(rbind,robidata)
S3method(reference_taxonomy,robilca)
S3method(reference_taxonomy,robitaxid)
S3method(reference_taxonomy,robitaxonomy)
S3method(rep,robicategory)
S3method(rep,robitag)
S3method(rep,robitag_forward)
S3method(rep,robitag_reverse)
S3method(rep,robitaxid)
S3method(rep,robitaxid_master)
S3method(rep,robiatomic)
S3method(reverse_tags,default)
S3method(reverse_tags,robimetabar)
S3method(reverse_tags,robisample)
......@@ -140,6 +108,7 @@ S3method(scientific_name,robimetabar)
S3method(scientific_name,robimotu)
S3method(scientific_name,robitaxid)
S3method(scientific_name,tbl)
S3method(seek_contaminents,robimetabar)
S3method(set_motus,data.frame)
S3method(set_motus,robimotu)
S3method(set_samples,robisample)
......@@ -155,7 +124,12 @@ S3method(taxids,robimetabar)
S3method(taxids,robimotu)
S3method(taxids_colname,robimetabar)
S3method(taxids_colname,tbl)
S3method(taxon_at_rank,numeric)
S3method(taxon_at_rank,robimetabar)
S3method(taxon_at_rank,robimotu)
S3method(taxon_at_rank,tbl)
S3method(taxonomic_parent,numeric)
S3method(taxonomic_parent,robimetabar)
S3method(taxonomic_parent,robimotu)
S3method(taxonomic_parent,robitaxid)
S3method(taxonomic_parent,tbl)
......@@ -174,21 +148,27 @@ S3method(type_sum,robitaxid)
S3method(type_sum,robitaxid_master)
S3method(type_sum,robiuniqueid)
S3method(validate_object,default)
S3method(validate_object,robiatomic)
S3method(validate_object,robidata)
S3method(validate_object,robimetabar)
S3method(validate_object,robimotu)
S3method(validate_object,robisample)
S3method(validate_robimetabar,robimetabar)
S3method(validate_object,robitag)
S3method(validate_object,robitaxid)
S3method(validate_object,robiuniqueid)
S3method(validate_robitaxonomy,robitaxonomy)
S3method(write.xlsx,default)
S3method(write.xlsx,robimetabar)
export("levels <- .robicategory")
export("motus<-")
export("samples<-")
export()
export(D_q)
export(H_q)
export(alternative_names)
export(alternative_taxids)
export(as.robimetabar.robiseq_db)
export(as_robiatomic)
export(as_robicategory)
export(as_robidata)
export(as_robimetabar)
......@@ -239,6 +219,7 @@ export(ids_colname)
export(int2nuc)
export(is_full_taxonomy)
export(is_robi_verbose)
export(is_robiatomic)
export(is_robicategory)
export(is_robidata)
export(is_robimetabar)
......@@ -263,6 +244,7 @@ export(motus_read_count)
export(motus_sample_count)
export(motus_sample_max)
export(motus_sample_min)
export(new_robiatomic)
export(new_robicategory)
export(new_robidata)
export(new_robilca)
......@@ -282,7 +264,6 @@ export(nmotus)
export(nodes)
export(nsamples)
export(nuc2int)
export(parent.robitaxonomy)
export(plot_read_x_motus)
export(rainbow_tol)
export(rank.list)
......@@ -294,7 +275,6 @@ export(read_ngsfilter)
export(read_obifasta)
export(read_obitab)
export(read_obitools_taxonomy)
export(read_robitaxonomy)
export(reference_taxonomy)
export(resets_category_tags)
export(reverse_tags)
......@@ -304,6 +284,7 @@ export(rkmer)
export(rnuc)
export(robiassert)
export(robiassert_arg)
export(robiatomic)
export(robicategory)
export(robicategory_mapping)
export(robidata)
......@@ -329,12 +310,12 @@ export(samples_motu_max)
export(samples_motu_min)
export(samples_read_count)
export(scientific_name)
export(seek_contaminents)
export(set_default_taxonomy)
export(set_motus)
export(set_sample.data.frame)
export(set_samples)
export(species)
export(spread_names.robitaxonomy)
export(superkingdom)
export(tags)
export(tags_colname)
......@@ -342,16 +323,14 @@ export(tags_positive_ctrls)
export(taxid.validate)
export(taxids)
export(taxids_colname)
export(taxon.at.rank)
export(taxon.path)
export(taxon_at_rank)
export(taxonomic_parent)
export(taxonomic_rank)
export(unclass_robiobject)
export(validate_object)
export(validate_robimetabar)
export(validate_robitaxonomy)
export(write.xlsx)
export(write_robitaxonomy)
import(R6)
import(doParallel)
import(dplyr)
......@@ -362,10 +341,14 @@ import(stringr)
import(tibble)
import(tidyr)
import(utils)
import(vctrs)
import(vegan)
import(xlsx)
importFrom(Rdpack,reprompt)
importFrom(glue,glue)
importFrom(pillar,pillar_shaft)
importFrom(pillar,type_sum)
importFrom(rlang,abort)
importFrom(rlang,inform)
importFrom(rlang,warn)
useDynLib(ROBITools2)
......@@ -141,7 +141,7 @@ left_parse_sample_ids <- function(object,parts,n,pattern="_",
#' @rdname left_parse_sample_ids
#' @export
left_parse_sample_ids.robisample <- function(object,parts,n,pattern="_",
left_parse_sample_ids.robidata <- function(object,parts,n,pattern="_",
category_mapping,
sample_categories = "category",
include_full = FALSE,
......@@ -179,7 +179,12 @@ left_parse_sample_ids.robisample <- function(object,parts,n,pattern="_",
category_mapping,
sample_categories,
replace,
prefix)
prefix) -> result
if (any(vapply(result,is_robicategory,TRUE)))
result %>% robisample()
else
result
}
#' @export
......
......@@ -20,6 +20,7 @@ NULL
#' @examples
read_metabar <- function(file,
keys = NULL,
ngsfilter = NULL,
motu_ids = "id",
read_count = "sample",
obiclean_prefix = "obiclean",
......@@ -111,8 +112,21 @@ read_metabar <- function(file,
features[[c]] <- fs
}
usampleids <- unique(data$sample)
if (!is.null(ngsfilter)) {
m <- match(usampleids,ids(ngsfilter) %>% pull(),NA)
missing <- usampleids[which(is.na(m))]
robiassert_arg(length(missing)==0,
"ngsfilter",
"The provided ngsfilter doesn't define all the samples. ({paste(missing,collapse=', ')}) are missing ")
samples <- robisample(ngsfilter)
} else {
samples <- robisample(usampleids)
}
robimetabar(motus = robimotu(features %>% select(id,everything())),
samples = robisample(levels(data$sample)),
samples = robisample(unique(data$sample)),
data = data,
verbose = verbose)
}
......@@ -71,8 +71,7 @@ feature_as_three_columns <- function(feature,motus_ids=NULL) {
motus_ids <- build_motu_names(n = seq_along(feature))
lengths <- vapply(feature, length, 0)
motus <- factor(rep(motus_ids,lengths),levels = levels(motus_ids))
samples <- factor(samples,levels = all_names)
motus <- rep(motus_ids,lengths)
values <- unlist(feature)
tibble(motu = motus,
......
#' @import vctrs
#' @include robiobject.R
NULL
#' Test if an object belongs \code{robiatomic} class
#'
#' @param object the object to test
#' @return a \code{logical} value
#'
#' @examples
#' xd <- new_robiatomic(1:10,class="robifoo")
#' is_robiatomic(xd)
#' is_robiatomic(1:10)
#'
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @export
is_robiatomic <- function(object) {
inherits(object, "robiatomic")
}
#' @details The \codse{\link[ROBITools2]{robiatomic}} version
#' ckecks that the instance is an atomic object.
#' @export
#'
#' @rdname validate_object
validate_object.robiatomic <- function(object, verbose=is_robi_verbose()) {
robiassert_arg(is_atomic(object),
"object",
"To be upgraded to the class robiatomic objects have to be atomic")
object
}
#' @param object the object to modify
#' @param ... Passed on to \code{\link[base]{structure}}()
#' @param class Subclasses to assign to the new object, default: none
#'
#' @rdname robiatomic
#' @export
new_robiatomic <- function(object,...,class=NULL) {
vc <- new_vctr(x, class = c(class, "robiatomic","robiobject"))
validate_object(vc)
}
#' Builds a new \code{robiatomic} instance.
#'
#' robiatomic is a subclass of \code{\link[tibble]{tibble}}.
#' It is notably the super class of \code{\link[ROBITools2]{robisample}}
#' and \code{\link[ROBITools2]{robimotu}}.
#' \code{robiatomic} must have an column belonging the
#' \code{\link[ROBITools2]{robiuniqueid}} class to insure a unique identifier.
#'
#'
#' @param object
#' @param id_column
#'
#' @return a \code{robiatomic} instance
#' @export
#'
#' @examples
robiatomic <- function(object) {
new_robiatomic(object)
}
#' @rdname robiatomic
#' @export
as_robiatomic <- function(object) {
UseMethod("as_robiatomic", object)
}
#' @rdname robiatomic
#' @export
as_robiatomic.default <- function(object) {
new_robiatomic(object)
}
#' @rdname robiatomic
#' @export
as_robiatomic.robiatomic <- function(object) {
classes <- class(object)
rclass <- which(classes == 'robiatomic')
class(object) <- classes[rclass:length(classes)]
object
}
#' @export
c.robiatomic <- function(...) {
#fcall = match.call()
d <- list(...)
all_robiatomic <- all(sapply(d,is_robiatomic))
#fcall[[1]] = quote(base::c)
result <- NextMethod()
if (all_robiatomic) {
classes <- lapply(d, class)
classes <- lapply(classes, rev)
mclass <- min(sapply(classes,length))
common_class <- classes[[1]][(which(sapply(1:mclass, function(i)
length(unique(sapply(classes,function(x) x[[i]]))) == 1
)) %>% rev())[1]]
fcall = call(paste0("new_",common_class),quote(result))
result <- tryCatch(eval(fcall),
error = function(e) robiatomic(result))
}
result
}
#' @export
rep.robiatomic <- function(x, ...) {
constructor <- paste0("new_",class(x)[1])
result <- NextMethod()
eval(call(constructor,quote(result)))
}
#' @export
`[.robiatomic` <- function(x, ..., drop = FALSE) {
constructor <- paste0("new_",class(x)[1])
result <- NextMethod()
eval(call(constructor,quote(result)))
}
#' @export
`[<-.robiatomic` <- function(x, ..., value) {
constructor <- paste0("new_",class(x)[1])
result <- NextMethod()
eval(call(constructor,quote(result)))
}
......@@ -69,15 +69,15 @@ new_robicategory <- function(object, ..., class = character()) {
)
}
validate_robicategory(
new_robiobject(object,
validate_object(
new_robiatomic(object,
...,
class = c(class, "robicategory")
)
)
}
validate_robicategory <- function(object) {
validate_object.robicategory <- function(object) {
stopifnot(identical(levels(object),.robi_all_categories))
if (any(is.na(object))) {
......@@ -111,7 +111,8 @@ validate_robicategory <- function(object) {
#' ))
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @export
robicategory <- function(object, verbose = TRUE) {
robicategory <- function(object = character(0), verbose = is_robi_verbose()) {
object <- as.character(object)
fac <- match(object, .robi_all_categories)
......@@ -120,12 +121,12 @@ robicategory <- function(object, verbose = TRUE) {
sum(is.na(fac)),
sprintf(
"The element %s doesn't belong one of the following categories",
(x[is.na(fac)])[1],
(object[is.na(fac)])[1],
substr(paste(deparse(.robi_all_categories), collapse = ""), 2, 1000)
),
sprintf(
"The elements %s don't belong one of the following categories",
substr(paste(deparse(unique(x[is.na(fac)])), collapse = ""), 2, 1000),
substr(paste(deparse(unique(object[is.na(fac)])), collapse = ""), 2, 1000),
substr(paste(deparse(.robi_all_categories), collapse = ""), 2, 1000)
),
))
......@@ -190,26 +191,7 @@ as_robicategory.robicategory <- function(object) {
object
}
#' @export
c.robicategory <- function(x, ...) {
new_robicategory(NextMethod())
}
#' @export
rep.robicategory <- function(x, ...) {
new_robicategory(NextMethod())
}
#' @export
`[.robicategory` <- function(x, i) {
new_robicategory(NextMethod())
}
#' @export
`[<-.robicategory` <- function(x, ..., value) {
new_robicategory(NextMethod())
}
#' Levels Attributes of a \code{robicategory}
#'
......
......@@ -28,12 +28,13 @@ is_robidata <- function(object) {
#'
#' @rdname validate_object
validate_object.robidata <- function(object, verbose=is_robi_verbose()) {
robiassert_arg(
sum(vapply(object, is_robiuniqueid, FUN.VALUE = TRUE))==1,
"object",
cuid <- sum(vapply(object, is_robiuniqueid, FUN.VALUE = TRUE))
robiassert_arg(cuid == 1,
"object",
"the {class} instance must have one and only one column of type robiuniqueid, not {count}",
class(object)[1],
count = sum(vapply(object, is_robiuniqueid, FUN.VALUE = TRUE)))
class = class(object)[1],
count = cuid)
object
}
......@@ -45,13 +46,13 @@ validate_object.robidata <- function(object, verbose=is_robi_verbose()) {
#'
#' @rdname robidata
#' @export
new_robidata <- function(object,...,class) {
new_robidata <- function(object,...,class=NULL) {
robiassert_arg(
is_tibble(object),
"object",
"Object of class {class} can only be built from a tibble instance",
class = class(object)[1])
class = class)
validate_object(new_robiobject(object,
...,
......@@ -175,3 +176,54 @@ ids.robidata <- function(object) {
ids_colname(object))
}
#' @export
rbind.robidata <- function(..., deparse.level = 1) {
result <- base::rbind.data.frame(..., deparse.level = deparse.level,
stringsAsFactors = FALSE)
if (is_robidata(result))
result %>%
mutate_if(is_robiatomic,validate_object) %>%
validate_object()
else
result
}
# # @export
# rbind.robidata <- function(..., deparse.level = 1,
# make.row.names = TRUE,
# stringsAsFactors = default.stringsAsFactors(),
# factor.exclude = NA) {
#
# fcall <- match.call()
# fcall[[1]] <- quote(base::rbind.data.frame)
#
# d <- list(...)
# all_robidata <- all(sapply(d,is_robidata))
# if (all_robidata) {
# ids_name <- unique(sapply(d,ids_colname))
# same_ids_name <- length(ids_name) == 1
# classes <- lapply(d, class)
# }
#
# result <- eval(fcall)
#
# if (all_robidata && same_ids_name) {
# classes <- lapply(classes, rev)
# mclass <- sapply(classes,length)
# common_class <- classes[[1]][(which(sapply(1:mclass, function(i)
# unique(sapply(classes,function(x) x[[i]])) == 1
# )) %>% rev())[1]]
#
# fcall = parse(text = "robidata(result)")
# fcall[[1]] = as.name(common_class)
#
# result[[ids_name]] <- robiuniqueid(result[[ids_name]])
# result <- eval(fcall)
# }
#
# result
# }
......@@ -60,7 +60,7 @@ NULL
if (!missing(distances))
self$distances <- distances
validate_robimetabar(self)
validate_object(self)
},
......@@ -73,28 +73,13 @@ NULL
)
)
#' Validates that a taxonomy instance respects some constraints.
#'
#'
#' @param object
#'
#' @return
#'
#' @examples
#' s <- robisample(n=20)
#' validate_robimetabar(s)
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @export
validate_robimetabar <- function(object, verbose=is_robi_verbose()) {
UseMethod("validate_robimetabar", object)
}
#' @detail The \code{robimetabar} version of this methode checks that
#' taxonomy declared as full verified that constaint.
#'
#' @rdname validate_robimetabar
#' @rdname validate_object
#' @export
validate_robimetabar.robimetabar <- function(object, verbose=TRUE) {
validate_object.robimetabar <- function(object, verbose=is_robi_verbose()) {
object
}
......
......@@ -16,6 +16,9 @@ NULL
#' @export
#'
validate_object <- function(object, verbose=is_robi_verbose()) {
if (length(object) == 0)
return(object)
UseMethod("validate_object",object)
}
......@@ -130,3 +133,5 @@ as_robiobject.robiobject <- function(object) {
as_robiobject.default <- function(object) {
new_robiobject(object)
}
#' @include robiobject.R
#' @include robiatomic.R
#' @import vctrs
#' @import tibble
#' @import dplyr
#' @import stringr
......@@ -20,19 +21,26 @@ is_robitag = function(object) {
inherits(object,'robitag')
}
validate_robitag <- function(object) {
#' @rdname validate_object
#' @export
validate_object.robitag <- function(object) {
lx <- nchar(object)
lx[is.na(lx)] <- 0
lmax <- max(lx, na.rm = TRUE)
same_length <- all(duplicated(lx)[-1])
if (any(lx != lmax & ! is.na(object))) {
stop("Every tags must have the same length.",
call. = FALSE
)
if (!same_length) {
strange = object[which(duplicated(lx)[-1]) + 1]
if (length(strange) > 20)
strange = c(strange[1:19],"and others...")
}
if (any(is.na(str_match(object,"^[ACGT]*$")) && ! is.na(object)))
robiassert_arg(same_length,
"object",
"Every tags must have the same length ({nchar(object[1])}). ({paste(strange,collapse=', ')} seem different)")
if (any(is.na(str_match(object,"^[ACGT]*$")) && !is.na(object)))
stop("Only uppercase A, C, G, and T are allowed in tags.",
call. = FALSE
)
......@@ -52,14 +60,10 @@ validate_robitag <- function(object) {
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @export
new_robitag <- function(object, ..., class = character()) {
if (!is.character(object)) {
stop("robitag can only be based on character vector",
call. = FALSE
)
}
vec_assert(object,character())
validate_robitag(
new_robiobject(as.character(object),
validate_object(
new_robiatomic(as.character(object),
...,
class = c(class, "robitag")
)
......@@ -88,14 +92,14 @@ new_robitag <- function(object, ..., class = character()) {
#'
#' @author Eric Coissac <eric.coissac@metabarcoding.org>
#' @export
robitag <- function(x, adapte_length=TRUE, verbose = TRUE) {
robitag <- function(x = character(0), adapte_length=TRUE, verbose = TRUE) {
x <- toupper(as.character(x))
lx <- nchar(x)
lx_min <- min(lx, na.rm = TRUE)