Following of the development...

.Rbuildignore

@@ -3,4 +3,3 @@
 ^external_data_pkg$
 ^LICENCE-CECILL-2.1.txt$
 ^data-raw$
-^R/robimetabar_xlsx.R$
\ No newline at end of file

DESCRIPTION

@@ -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'

NAMESPACE

@@ -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)

R/as_motu_matrix.R

@@ -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

R/dplyr.R

@@ -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

R/entropie.R

@@ -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))

R/metabar_data_class.R

@@ -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)
+}
+
 

R/robicategory.R

@@ -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))
+}
+

R/robimetabar.R

@@ -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

R/robimetabar_aggregate.R

+#' @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

R/robimetabar_filter.R

@@ -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

R/robimetabar_store.R

+#' @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)
+}

R/robimetabar_xlsx.R

 #' @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))))
 }