Commit 81b263d0 authored by Eric Coissac's avatar Eric Coissac

Following of the development...

parent 67d40585
......@@ -3,4 +3,3 @@
^external_data_pkg$
^LICENCE-CECILL-2.1.txt$
^data-raw$
^R/robimetabar_xlsx.R$
\ No newline at end of file
......@@ -9,7 +9,7 @@ Description: More about what it does (maybe more than one line)
License: CeCILL-2
Encoding: UTF-8
LazyData: true
RoxygenNote: 7.1.0
RoxygenNote: 7.1.1
VignetteBuilder: knitr
Imports: R6,
vctrs (>= 0.3.0),
......@@ -18,7 +18,7 @@ Imports: R6,
Rdpack,
rlang,
ggplot2,
xlsx
openxlsx
RdMacros: Rdpack
Suggests: vegan,
roxygen2,
......@@ -60,8 +60,10 @@ Collate:
'read_metabar.R'
'read_ngsfilter.R'
'read_obitab.R'
'robimetabar_aggregate.R'
'robimetabar_filter.R'
'robimetabar_stat.R'
'robimetabar_store.R'
'robimetabar_xlsx.R'
'robimutation.R'
'robiseq_db.R'
......
......@@ -105,10 +105,12 @@ 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)
S3method(sort,robipath)
S3method(store_into,robimotu)
S3method(store_into,robisample)
S3method(store_into_motus,data.frame)
S3method(store_into_motus,robimotu)
S3method(store_into_samples,robisample)
S3method(tagjump,robimetabar)
S3method(tags,default)
S3method(tags,robimetabar)
......@@ -143,6 +145,7 @@ S3method(type_sum,robitag)
S3method(type_sum,robitag_forward)
S3method(type_sum,robitag_reverse)
S3method(type_sum,robiuniqueid)
S3method(unique,robicategory)
S3method(validate_object,default)
S3method(validate_object,robi4mer)
S3method(validate_object,robiatomic)
......@@ -307,11 +310,14 @@ S3method(vec_ptype_abbr,robitaxid)
S3method(vec_ptype_abbr,robitaxid_master)
S3method(vec_ptype_abbr,robiuniqueid)
S3method(vec_ptype_full,robitaxid)
S3method(write_xlsx,default)
S3method(write_xlsx,robimetabar)
export("levels <- .robicategory")
export("motus<-")
export("samples<-")
export(D_q)
export(H_q)
export(aggregate_robidata)
export(alternative_names)
export(alternative_taxids)
export(as.robimetabar.robiseq_db)
......@@ -359,6 +365,12 @@ export(expand_names)
export(family)
export(feature_as_matrix)
export(filter_motus)
export(filter_motus_empty)
export(filter_sample_category)
export(filter_sample_empty)
export(filter_sample_max_diversity)
export(filter_sample_max_read)
export(filter_sample_min_diversity)
export(filter_sample_min_read)
export(filter_tag_gcmax)
export(filter_tag_homopolymere)
......@@ -403,6 +415,7 @@ export(lowest_common_ancestor)
export(master_taxids)
export(master_taxids_colname)
export(motus)
export(motus_average)
export(motus_ids)
export(motus_ids_colname)
export(motus_ranks)
......@@ -480,6 +493,7 @@ export(robitaxid_master)
export(robiuniqueid)
export(rseq)
export(samples)
export(samples_average)
export(samples_entropy)
export(samples_hill)
export(samples_ids)
......@@ -491,11 +505,12 @@ 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(store_into)
export(store_into_motus)
export(store_into_sample.data.frame)
export(store_into_samples)
export(substitution)
export(superkingdom)
export(tagjump)
......@@ -533,10 +548,12 @@ export(vec_ptype2.robitaxid)
export(vec_ptype2.robitaxid_master)
export(vec_ptype2.robiuniqueid)
export(write_robitaxonomy)
export(write_xlsx)
import(R6)
import(doParallel)
import(dplyr)
import(foreach)
import(openxlsx)
import(purrr)
import(readr)
import(rlang)
......
......@@ -8,12 +8,15 @@ NULL
#'
#' @param metabar
#' @param value
#' @param values_fill
#' @param transpose
#'
#' @return
#' @export
#'
#' @examples
as_motus_matrix <- function(metabar,value = "count", values_fill = 0) {
as_motus_matrix <- function(metabar,value = "count",
values_fill = 0,transpose = FALSE) {
metabar$data %>%
select(sample,motu,data = !! value) %>%
dt_pivot_wider(names_from = motu,values_from = data) -> mat
......@@ -24,7 +27,10 @@ as_motus_matrix <- function(metabar,value = "count", values_fill = 0) {
rownames(mat) <- row_names
mat[is.na(mat)] <- values_fill
mat
if (transpose)
t(mat)
else
mat
}
#' Title
......
......@@ -2,3 +2,14 @@
#' @include robiobject.R
NULL
group.robisample <- function (x, y,
by = NULL,
copy = FALSE,
suffix = c(".x", ".y"),
..., keep = FALSE)
{
call = match.call()
call[[1]] = quote(dplyr::left_join)
call[[2]] = quote(unclass_robiobject(x))
eval(call) %>% robisample()
}
\ No newline at end of file
......@@ -71,6 +71,7 @@ dd_exp_q = function(x, q = 1) {
#' @author Eric Coissac
#' @export
H_q = function(x, q = 1, normalize = TRUE) {
x = x[x>0]
if (normalize)
x <- x/sum(x)
sum(x * log_q( 1 / x, q))
......
......@@ -125,14 +125,14 @@ motus <- function(data) {
#' @rdname motus
#' @export
set_motus <- function(value, data) {
UseMethod("set_motus", value)
store_into_motus <- function(value, data) {
UseMethod("store_into_motus", value)
}
#' @rdname motus
#' @export
`motus<-` <- function(data, value ) {
value %>% set_motus(data)
value %>% store_into_motus(data)
invisible(data)
}
......@@ -145,16 +145,21 @@ samples <- function(data) {
#' @rdname motus
#' @export
set_samples <- function(value, data) {
UseMethod("set_samples", value)
store_into_samples <- function(value, data) {
UseMethod("store_into_samples", value)
}
#' @rdname motus
#' @export
`samples<-` <- function(data, value ) {
value %>% set_samples(data)
value %>% store_into_samples(data)
invisible(data)
}
#' @export
store_into <- function(value, data) {
UseMethod("store_into", value)
}
......@@ -384,3 +384,23 @@ pillar_shaft.robicategory <- function(x, ...) {
}
#' Title
#'
#' @param x
#' @param incomparables
#' @param fromLast
#' @param nmax
#' @param ...
#'
#' @return
#' @export
#'
#' @examples
unique.robicategory <- function(x, incomparables = FALSE,
fromLast = FALSE, nmax = NA,
...) {
call = match.call()
call[[1]] <- quote(unique.default)
as_robicategory(eval(call))
}
......@@ -165,7 +165,7 @@ new_robimetabar <- function(data,
#' rownames(reads) <- c("sample_1", "sample_2", "sample_3")
#' colnames(reads) <- c("motu_1", "motu_2", "motu_3", "motu_4")
#'
#' metabar <- robimetabar(reads = reads)
#' metabar <- robimetabar(data = reads)
#'
#' samples(metabar)
#' motus(metabar)
......@@ -242,7 +242,7 @@ robimetabar <- function(data, samples, motus,
if (verbose) message("missing sample descriptions")
if (!is.null(sample_names))
samples = robisample(tibble(id = robiuniqueid(sample_names)))
samples = robisample(tibble(id = as_robiuniqueid(sample_names)))
else {
if (verbose) message("no row names on the data matrix")
samples = robisample(n = c(pcr = nrow(data)))
......@@ -278,7 +278,7 @@ robimetabar <- function(data, samples, motus,
else {
if (verbose) message("missing motus descriptions")
if (!is.null(motus_names))
motus = robimotu(tibble(id = robiuniqueid(motus_names)))
motus = robimotu(tibble(id = as_robiuniqueid(motus_names)))
else {
if (verbose) message("no column names on the data matrix")
motus = robimotu(n = ncol(data))
......@@ -425,43 +425,6 @@ motus.robimetabar <- function(data) {
data$motus
}
#' @rdname motus
#' @export
set_samples.robisample <- function(value, data) {
robiassert_arg(is_robimetabar(data),
"data",
"the data parameter must belong the class robimetabar, not {dclass}",
dclass = class(data)[1])
data$samples <- value
invisible(data)
}
#' @rdname motus
#' @export
set_sample.data.frame <- function(value, data) {
set_sample.robimotu(robisample(value),data)
}
#' @rdname motus
#' @export
set_motus.robimotu <- function(value, data) {
robiassert_arg(is_robimetabar(data),
"data",
"the data parameter must belong the class robimetabar, not {dclass}",
dclass = class(data)[1])
data$motus <- value
invisible(data)
}
#' @rdname motus
#' @export
set_motus.data.frame <- function(value, data) {
set_motus.robimotu(robimotu(value),data)
}
#' @author Eric Coissac
#' @export
......
#' @include robimetabar.R
#' @import dplyr
#'
NULL
identical_or_na <- function(x) {
x <- unique(x)
if (length(x) == 1)
x
else
NA
}
#' Title
#'
#' @param data
#' @param key
#'
#' @return
#' @export
#'
#' @examples
aggregate_robidata <- function(data,key) {
id_col = ids_colname(data)
data %>%
mutate(`__key__` = key) %>%
select(-!!id_col) %>%
group_by(`__key__`) %>%
summarise_all(identical_or_na) %>%
mutate(!!id_col:=as_robiuniqueid(as.character(`__key__`))) %>%
select(-`__key__`) %>%
select(!!id_col,everything()) -> data
sapply(data,function(c) !all(is_na(c))) -> to_keep
data[,to_keep] %>% as_robidata()
}
samples_average_data <- function(metabar,key) {
id_col = samples_ids_colname(metabar)
bys <- "sample"
names(bys) = id_col
samples(metabar) -> s
s$`__key__` <- as.character(key)
s %>%
select(!!id_col,`__key__`) %>%
group_by(`__key__`) %>%
mutate(`__gsize__` = length(`__key__`)) %>%
ungroup() %>%
right_join(metabar$data %>%
group_by(sample) %>%
mutate(`__scount__` = sum(count),
`__rel_freq__` = count/`__scount__`) %>%
ungroup(),
by = bys) %>%
select(-!!id_col) %>%
group_by(`__key__`,motu) %>%
summarise(count = sum(`__rel_freq__`)/`__gsize__`[1] * `__scount__`[1]) %>%
select(sample=`__key__`,motu,count) %>%
ungroup()
}
motus_average_data <- function(metabar,key) {
id_col = motus_ids_colname(metabar)
bys <- "motu"
names(bys) = id_col
motus(metabar) %>%
mutate(`__key__` = as.character(key)) %>%
select(!!id_col,`__key__`) %>%
right_join(metabar$data,by = bys) %>%
select(-!!id_col) %>%
group_by(`__key__`,sample) %>%
summarise_all(mean) %>%
select(sample,motu=`__key__`,everything())
}
#' Title
#'
#' @param metabar
#' @param key
#'
#' @return
#' @export
#'
#' @examples
samples_average <- function(metabar,key) {
data <- samples_average_data(metabar,key)
samples <- aggregate_robidata(samples(metabar),key) %>%
as_robisample()
motus <- motus(metabar)
new_robimetabar(data = data,
samples = samples,
motus = motus)
}
#' Title
#'
#' @param metabar
#' @param key
#'
#' @return
#' @export
#'
#' @examples
motus_average <- function(metabar,key) {
data <- motus_average_data(metabar,key)
motus <- aggregate_robidata(motus(metabar),key) %>%
as_robimotu()
samples <- samples(metabar)
new_robimetabar(data = data,
samples = samples,
motus = motus)
}
\ No newline at end of file
......@@ -3,7 +3,54 @@
#'
NULL
#' Filters out samples based on reacd count.
filter_data_orphean <- function(metabar) {
metabar$data[ metabar$data$motu %in% pull(motus_ids(metabar)) &
metabar$data$sample %in% pull(samples_ids(metabar)),] -> metabar$data
invisible(metabar)
}
#' Remove samples with no more reads associated to them.
#'
#' @param metabar
#'
#' @return
#' @export
#'
#' @examples
filter_sample_empty <- function(metabar) {
metabar$data %>%
group_by(sample) %>%
summarise(.total__ = sum(count)) %>%
filter(.total__ > 0) %>%
pull(sample) -> skeep
samples(metabar)[(samples_ids(metabar) %>% pull()) %in% skeep,] -> metabar$samples
invisible(filter_data_orphean(metabar))
}
#' Remove MOTUs with no more reads associated to them.
#'
#' @param metabar
#'
#' @return
#' @export
#'
#' @examples
filter_motus_empty <- function(metabar) {
metabar$data %>%
group_by(motu) %>%
summarise(.total__ = sum(count)) %>%
filter(.total__ > 0) %>%
pull(motu) -> skeep
motus(metabar)[(motus_ids(metabar) %>% pull()) %in% skeep,] -> metabar$motus
invisible(filter_data_orphean(metabar))
}
#' Filters out samples based on read count.
#'
#' Filters out samples having less than the specified minimum
#' number of reads in total.
......@@ -15,7 +62,8 @@ NULL
#'
#' @return the modified robimetabar object
#' @export
#'
#' @md
#' @seealso `filter_sample_empty`, `filter_motus_empty`
#' @examples
filter_sample_min_read <- function(metabar,min_read,
remove_empty_samples = TRUE,
......@@ -27,15 +75,139 @@ filter_sample_min_read <- function(metabar,min_read,
select(-.total__) %>%
ungroup() -> metabar$data
if (remove_empty_samples) {
metabar$data %>%
group_by(sample) %>%
summarise(.total__ = sum(count)) %>%
filter(.total__ > 0) %>%
pull(sample) -> skeep
if (remove_empty_samples)
filter_sample_empty(metabar)
samples(metabar)[(samples_ids(metabar) %>% pull()) %in% skeep,] -> metabar$samples
}
if (remove_empty_motus)
filter_motus_empty(metabar)
invisible(metabar)
}
#' Filters out samples based on read count.
#'
#' `filter_sample_max_read` filters out samples having more than the specified maximum
#' number of reads in total.
#'
#' @param max_read
#'
#'
#' @rdname filter_sample_min_read
#' @md
#' @examples
#' @export
filter_sample_max_read <- function(metabar,max_read,
remove_empty_samples = TRUE,
remove_empty_motus = TRUE) {
metabar$data %>%
group_by(sample) %>%
mutate(.total__ = sum(count)) %>%
filter(.total__ <= max_read) %>%
select(-.total__) %>%
ungroup() -> metabar$data
if (remove_empty_samples)
filter_sample_empty(metabar)
if (remove_empty_motus)
filter_motus_empty(metabar)
invisible(metabar)
}
#' Filters out samples based on diversity.
#'
#' Filters out samples having a diversity below the specified minimum
#' Hill's number specified.
#'
#' @param metabar
#' @param remove_empty_samples
#' @param remove_empty_motus
#' @param min_diversity
#' @param q
#'
#' @return the modified robimetabar object
#' @export
#'
#' @examples
filter_sample_min_diversity <- function(metabar,min_diversity, q = 1,
remove_empty_samples = TRUE,
remove_empty_motus = TRUE) {
metabar$data %>%
group_by(sample) %>%
mutate(.diversity__ = D_q(count,q = q)) %>%
filter(.diversity__ >= min_diversity) %>%
select(-.diversity__) %>%
ungroup() -> metabar$data
if (remove_empty_samples)
filter_sample_empty(metabar)
if (remove_empty_motus)
filter_motus_empty(metabar)
invisible(metabar)
}
#' Filters out samples based on diversity.
#'
#' Filters out samples having a diversity below the specified minimum
#' Hill's number specified.
#'
#' @param metabar
#' @param remove_empty_samples
#' @param remove_empty_motus
#' @param min_diversity
#' @param q
#'
#' @return the modified robimetabar object
#' @export
#'
#' @rdname filter_sample_min_diversity
#' @examples
filter_sample_max_diversity <- function(metabar,max_diversity, q = 1,
remove_empty_samples = TRUE,
remove_empty_motus = TRUE) {
metabar$data %>%
group_by(sample) %>%
mutate(.diversity__ = D_q(count,q = q)) %>%
filter(.diversity__ <= min_diversity) %>%
select(-.diversity__) %>%
ungroup() -> metabar$data
if (remove_empty_samples)
filter_sample_empty(metabar)
if (remove_empty_motus)
filter_motus_empty(metabar)
invisible(metabar)
}
#' Filters out samples based on category
#'
#' Filters out samples having not belonging the specified sample categories.
#'
#' @param metabar
#' @param remove_empty_samples
#' @param category
#' @param remove_empty_motus
#'
#' @return the modified robimetabar object
#' @export
#'
#' @examples
filter_sample_category <- function(metabar,category,
remove_empty_samples = TRUE,
remove_empty_motus = TRUE) {
samples(metabar)[pull(categories(metabar)) %in% category,] -> metabar$samples
if (remove_empty_samples)
filter_sample_empty(metabar)
if (remove_empty_motus)
filter_motus_empty(metabar)
invisible(metabar)
}
\ No newline at end of file
#' @import dplyr
#' @import tidyr
#' @import tibble
#'
#' @include robimetabar_filter.R
#' @include robisample.R
#' @include robimotu.R
#'
NULL
#' @rdname motus
#' @export
store_into_samples.robisample <- function(value, data) {
robiassert_arg(is_robimetabar(data),
"data",
"the data parameter must belong the class robimetabar, not {dclass}",
dclass = class(data)[1])
data$samples <- value
invisible(data)
}
#' @rdname motus
#' @export
store_into_sample.data.frame <- function(value, data) {
store_into_sample.robimotu(robisample(value),data)
}
#' @rdname motus
#' @export
store_into_motus.robimotu <- function(value, data) {
robiassert_arg(is_robimetabar(data),
"data",
"the data parameter must belong the class robimetabar, not {dclass}",
dclass = class(data)[1])
data$motus <- value
invisible(data)
}
#' @export
store_into.robimotu <- function(value, data) {
invisible(store_into_motus.robimotu(value, data))
}
#' @export
store_into.robisample <- function(value, data) {
invisible(store_into_samples.robisample(value, data))
}
#' @rdname motus
#' @export
store_into_motus.data.frame <- function(value, data) {
store_into_motus.robimotu(robimotu(value),data)
}
#' @include robimetabar.R
#'
#' @import dplyr
#' @import xlsx
#' @import openxlsx
NULL
#' @author Eric Coissac
#' @export
write.xlsx.default = xlsx::write.xlsx
write_xlsx = function(x, file, asTable = FALSE, ...) {
UseMethod("write_xlsx",x)
}
#' @author Eric Coissac
#' @export
write.xlsx = function(x, file, sheetName = "Sheet1",
col.names = TRUE, row.names = TRUE,
append = FALSE, showNA = TRUE, password = NULL) {
UseMethod("write.xlsx",x)
write_xlsx.default = openxlsx::write.xlsx
flat_tibble <-function(data) {
as_tibble(do.call(c,lapply(data,
function(x) if (is.list(x)) x else list(x))))
}