minor updates

- add filter_records object
- add wherever helper function
- update documentation

DESCRIPTION

@@ -84,6 +84,7 @@ Collate:
     'filter_labels_class.R'
     'filter_na_class.R'
     'filter_range_class.R'
+    'filter_records_class.R'
     'filter_venn_class.R'
     'github_file_class.R'
     'go_database_class.R'

NAMESPACE

@@ -51,6 +51,7 @@ export(excel_database)
 export(filter_labels)
 export(filter_na)
 export(filter_range)
+export(filter_records)
 export(filter_venn)
 export(github_file)
 export(hmdb_lookup)
@@ -88,6 +89,7 @@ export(split_records)
 export(sqlite_database)
 export(trim_whitespace)
 export(unique_records)
+export(wherever)
 exportMethods(chart_plot)
 exportMethods(check_for_columns)
 exportMethods(is_writable)
@@ -104,6 +106,13 @@ import(ggplot2)
 import(ggthemes)
 import(httr)
 import(methods)
+import(patchwork)
 import(rlang)
+import(struct)
 importFrom(scales,manual_pal)
+importFrom(utils,URLencode)
 importFrom(utils,capture.output)
+importFrom(utils,modifyList)
+importFrom(utils,read.csv)
+importFrom(utils,stack)
+importFrom(utils,unzip)

R/BiocFileCache_database_class.R

@@ -159,11 +159,15 @@ setMethod(
         field = "rtype", query = "web"
     )$rid) {
         # TRUE if newly added or stale
-        update <- BiocFileCache::bfcneedsupdate(bfc, rid)
+        update = BiocFileCache::bfcneedsupdate(bfc, rid)
+        if (is.na(update)) { # FALSE if NA
+            update=FALSE
+        }
     } else {
-        update <- FALSE # cant update if not web resource
+        update = FALSE # cant update if not web resource
     }
-
+
+
     # download & unzip
     if (update & !obj$offline) {
         BiocFileCache::bfcdownload(

R/MetMashR-package.R

@@ -1,3 +1,6 @@
+#' @import struct
+#' @import patchwork
+#' @importFrom utils URLencode modifyList read.csv stack unzip
 #' @keywords internal
 "_PACKAGE"
 

R/combine_records_class.R

@@ -402,6 +402,7 @@ NULL
 #' values.
 #' @param digits (numeric) the number of digits to use when converting numerical
 #' values to characters when determining if values are unique.
+#' @param sort (logical) sort the values before collapsing.
 #' @examples
 #'
 #' # Collapse unique values
@@ -410,11 +411,14 @@ NULL
 #'     default_fcn = .unique(
 #'         digits = 6,
 #'         separator = ", ",
-#'         na_string = "NA"
+#'         na_string = "NA",
+#'         sort = FALSE
 #'     )
 #' )
 #' @export
-.unique <- function(separator, na_string = "NA", digits = 6, drop_na = FALSE) {
+.unique <- function(separator, na_string = "NA", digits = 6, drop_na = FALSE,
+                    sort = FALSE
+                    ) {
     fcn <- expr(function(x) {
         if (is.numeric(x)) {
             x <- round(as.numeric(x), !!digits)
@@ -430,6 +434,9 @@ NULL
 
         x[is.na(x)] <- !!na_string
         x <- unique(x)
+        if (sort){
+            x=sort(x)
+        }
         paste0(x, collapse = !!separator)
     })
     return(eval(fcn))

R/filter_records_class.R

@@ -0,0 +1,104 @@
+#' Filter helper function to select records
+#' 
+#' Returns a list of quosures for use with 
+#' `filter_records` to allow the use of dplyr-style expressions. See examples.
+#' 
+#' @param ... Expressions that return a logical value and are defined in terms 
+#' of the columns in the annotation_source. If multiple conditions are 
+#' included then they are combined with the `&` operator. Only records 
+#' for which all conditions evaluate to `TRUE` are kept.
+#' 
+#' @examples
+#' # some annotation data
+#' AN = annotation_source(data = iris)
+#' 
+#' # filter to setosa where Sepal length is less than 5
+#' M = filter_records(
+#'         wherever(
+#'             Species == 'setosa', 
+#'             Sepal.Length<5
+#'         )
+#'     )
+#' M = model_apply(M,AN)
+#' predicted(M) # 20 rows
+#' 
+#' @returns a list of quosures for use with `filter_records`
+#' @seealso [filter_records()]
+#' @export
+wherever = function(...){
+    Q = quos(..., .ignore_empty = "all")
+    return(Q)
+}
+
+#' @eval get_description('filter_records')
+#' @export
+#' @include annotation_source_class.R
+#' @seealso [dplyr::filter()]
+#' @seealso [wherever()]
+#' @import rlang
+filter_records <- function(where = wherever(A>0), ...) {
+
+    out <- struct::new_struct(
+        "filter_records",
+        where = where,
+        ...
+    )
+    return(out)
+}
+
+
+.filter_records <- setClass(
+    "filter_records",
+    contains = c("model"),
+    slots = c(
+        updated = "entity",
+        where = "entity"
+    ),
+    prototype = list(
+        name = "Filter rows",
+        description = paste0(
+            "A wrapper around [`dplyr::filter`]. Select rows ",
+            "from an annotation table using tidy grammar."
+        ),
+        type = "filter",
+        predicted = "updated",
+        .params = c("where"),
+        .outputs = c("updated"),
+        libraries = c("dplyr", "rlang"),
+        updated = entity(
+            name = "Updated annotations",
+            description = paste0(
+                "The updated annotations as an `annotation_source` object"
+            ),
+            type = "annotation_source"
+        ),
+        where = entity(
+            name = "Select rows expression",
+            description = paste0(
+                'A list of [`rlang::quosure`] for evaluation e.g. A>10 will',
+                'select all rows where the values in column A are greater than',
+                '10. A helper function [`wherever`] is provided to generate',
+                'a suitable list of quosures.'
+            ),
+            value = quos(A>10),
+            type = 'quosures'
+        )
+    )
+)
+
+
+#' @export
+setMethod(
+    f = "model_apply",
+    signature = c("filter_records", "annotation_source"),
+    definition = function(M, D) {
+
+        q = M$where
+
+        D$data = filter(.data = D$data,!!!q)
+
+        M$updated = D
+
+        return(M)
+    }
+)

R/hmdb_lookup_class.R

@@ -1,18 +1,19 @@
 #' @eval get_description('hmdb_lookup')
 #' @export
 #' @include annotation_source_class.R rest_api_class.R
-hmdb_lookup <- function(query_column,
-                        suffix = "_hmdb",
-                        output = "inchikey",
-                        ...) {
+hmdb_lookup <- function(
+        query_column,
+        suffix = "_hmdb",
+        output = "inchikey",
+        ...) {
     out <- struct::new_struct(
         "hmdb_lookup",
         query_column = query_column,
         suffix = suffix,
         output = output,
         ...
     )
-
+    
     return(out)
 }
 

R/select_columns_class.R

@@ -64,13 +64,13 @@ setMethod(
     signature = c("select_columns", "annotation_source"),
     definition = function(M, D) {
         # column indexes matching expression
-        loc <- tidyselect::eval_select(M$expression, data = D$data)
+        loc = tidyselect::eval_select(M$expression, data = D$data)
 
         # update names
-        D$data <- rlang::set_names(D$data[loc], names(loc))
+        D$data = rlang::set_names(D$data[loc], names(loc))
 
         # update object
-        M$updated <- D
+        M$updated = D
 
         return(M)
     }

R/zzz.R

@@ -78,5 +78,8 @@ get_description <- function(id) {
     str <- gsub("[a annotation_source]", "annotation_source()", str,
         fixed = TRUE
     )
+    str <- gsub("[a quosures]", "wherever(A>10)", str,
+                fixed = TRUE
+    )
     return(str)
 }

_pkgdown.yml

@@ -88,6 +88,7 @@ reference:
   - filter_range
   - filter_na
   - filter_venn
+  - filter_records
   - id_counts
   - mz_match
   - rt_match
@@ -154,6 +155,7 @@ reference:
   contents:
   - check_for_columns
   - required_cols
+  - wherever
 home:
   links:
   - text: View on Bioconductor