mongodb additions to add / complete all methods

NAMESPACE

@@ -15,6 +15,7 @@ S3method(docdb_delete,src_sqlite)
 S3method(docdb_exists,src_couchdb)
 S3method(docdb_exists,src_elastic)
 S3method(docdb_exists,src_etcd)
+S3method(docdb_exists,src_mongo)
 S3method(docdb_exists,src_redis)
 S3method(docdb_exists,src_sqlite)
 S3method(docdb_get,src_couchdb)
@@ -29,6 +30,7 @@ S3method(docdb_query,src_elastic)
 S3method(docdb_query,src_mongo)
 S3method(docdb_query,src_sqlite)
 S3method(docdb_update,src_couchdb)
+S3method(docdb_update,src_mongo)
 S3method(docdb_update,src_sqlite)
 S3method(print,src_couchdb)
 S3method(print,src_elastic)

R/create.R

@@ -2,7 +2,7 @@
 #'
 #' @export
 #' @param src source object, result of call to an [src] function
-#' @param key (chartacter) A key. ignored for mongo
+#' @param key (character) A key (collection for mongo)
 #' @param value (data.frame) A single data.frame
 #' @param ... Ignored
 #' @template deets
@@ -30,7 +30,7 @@
 #' docdb_delete(src, "mtcars")
 #'
 #' # MongoDB
-#' src <- src_mongo()
+#' src <- src_mongo(collection = "mtcars")
 #' docdb_create(src, key = "mtcars", value = mtcars)
 #' docdb_get(src, "mtcars")
 #' 
@@ -76,8 +76,103 @@ docdb_create.src_redis <- function(src, key, value, ...) {
 
 #' @export
 docdb_create.src_mongo <- function(src, key, value, ...){
+
   assert(value, 'data.frame')
-  src$con$insert(value, ...)
+
+  # check expectations
+  if (exists("key", inherits = FALSE) && 
+      src$collection != key) 
+    message("Parameter 'key' is different from parameter 'collection', ",
+            "was given as ", src$collection, " in src_mongo().")
+
+  # Document identifier is created by mongolite
+  # from _id column or row.names of dataframe "value". 
+  # If dataframe has _id column, ensure it is character
+  # to emulate how row.names is used by mongolite.
+
+  if (any(grepl("_id", names(value)))) {
+    value[["_id"]] <- as.character(value[["_id"]])
+  }
+
+  # mongolite: 
+  # insert(data, pagesize = 1000, stop_on_error = TRUE, ...)
+  # 
+  # Insert rows into the collection. 
+  # Argument 'data' must be a 
+  # - data-frame, 
+  # - named list (for single record) or 
+  # - character vector with json strings (one string for each row). 
+  # 
+  # For lists and data frames, arguments 
+  # in ... get passed to jsonlite::toJSON
+
+  # check if _id in data.frame
+  idcol <- grep("_id", names(value))
+  valcol <- 1L + ifelse(length(idcol), 1L, 0L)
+
+  # Check if data.frame has one or two 
+  # columns where the non-_id column is
+  # already filled with json strings: 
+  if (ncol(value) == (1L + ifelse(length(idcol) != 0L, 1L, 0L)) &&
+      all(sapply(value[, valcol], is.character)) &&
+      all(sapply(value[, valcol], jsonlite::validate))) {
+
+    # True, thus now add json strings as documents.
+    # Iterate over rows if any in data.frame value
+    nrowaffected <- sapply(seq_len(nrow(value)), function(i) {
+
+      # minify
+      value[i, valcol] <- as.character(jsonlite::minify(value[i, valcol]))
+
+      # check if subids (_id's) in json strings, extract them
+      subids <- gregexpr('"_id":".*?"', value[i, valcol])
+      subids <- regmatches(value[i, valcol], subids)
+      subids <- sub(".*:\"(.*)\".*", "\\1", unlist(subids))
+
+      if (length(subids)) {
+
+        # if not in square brackets, add them 
+        if (!grepl("^\\[.*\\]$", value[i, valcol]))
+          value[i, -idcol] <- paste0('[', value[i, valcol], ']')
+
+        # splice value element into json elements
+        subvalue <- jsonlite::fromJSON(value[i, valcol], simplifyVector = FALSE)
+        subvalue <- sapply(subvalue, function(x) jsonlite::toJSON(x, auto_unbox = TRUE))
+
+        # iterate over elements and each has an _id
+        sapply(seq_along(subvalue), function(ii){
+
+          # insert
+          src$con$insert(subvalue[ii], ...)$nInserted
+
+        })
+
+      } else {# no subids
+
+        # add _id into beginning of json string, 
+        # if the json string does not yet have it.
+        tmpvalue <- value[i, valcol, drop = TRUE]
+        if (length(idcol) && !grepl('"_id"', tmpvalue)) 
+          tmpvalue <- jsonlite::toJSON(c(list("_id" = value[i, idcol, drop = TRUE]), 
+                                         jsonlite::fromJSON(tmpvalue)), auto_unbox = TRUE)
+
+        # insert
+        src$con$insert(data = tmpvalue, ...)$nInserted
+
+      }
+
+    })
+
+  } else {# no character vecto with json strings in data.frame
+
+    # standard method to add data.frame
+    nrowaffected <- src$con$insert(data = value, ...)$nInserted
+
+  }
+
+  # return number of created rows in table
+  return(invisible(sum(nrowaffected, na.rm = TRUE)))
+
 }
 
 #' @export

R/delete.R

@@ -3,7 +3,7 @@
 #' @export
 #' @param src source object, result of call to src, an
 #' object of class `docdb_src`
-#' @param key (chartacter) A key. ignored for mongo
+#' @param key (character) A key (collection for mongo)
 #' @param ... Ignored for now
 #' @template deets
 #' @examples \dontrun{
@@ -32,7 +32,7 @@
 #' docdb_delete(src, "mtcars")
 #'
 #' # mongo
-#' src <- src_mongo("stuff")
+#' src <- src_mongo(collection = "iris")
 #' docdb_create(src, "iris", iris)
 #' docdb_get(src, "iris")
 #' docdb_delete(src)
@@ -73,7 +73,34 @@ docdb_delete.src_redis <- function(src, key, ...) {
 
 #' @export
 docdb_delete.src_mongo <- function(src, key, ...) {
-  src$con$drop()
+
+  # check expectations
+  if (exists("key", inherits = FALSE) && 
+      src$collection != key) 
+    message("Parameter 'key' is different from parameter 'collection', ",
+            "was given as ", src$collection, " in src_mongo().")
+
+  # https://docs.mongodb.com/manual/tutorial/remove-documents/
+  # https://jeroen.github.io/mongolite/manipulate-data.html#remove
+
+  # make dotted parameters accessible
+  tmpdots <- list(...)
+
+  # if valid json, try to delete 
+  # document(s) instead of collection
+  if (!is.null(tmpdots$query) && 
+      jsonlite::validate(tmpdots$query)) {
+
+    # delete document
+    src$con$remove(query = tmpdots$query, 
+                   just_one = FALSE)
+
+  } else {
+
+    # delete collection
+    src$con$drop()
+
+  }
 }
 
 #' @export

R/exists.R

@@ -70,8 +70,32 @@ docdb_exists.src_redis <- function(src, key, ...) {
   switch(as.character(src$con$EXISTS(key)), "1" = TRUE, "0" = FALSE)
 }
 
-# docdb_exists.src_mongo <- function(src, key, ...) return(TRUE)
+#' @export
+docdb_exists.src_mongo <- function(src, key, ...) {
+  assert(key, 'character')
+
+  # need to connect to check collection key
+  test <- src_mongo(collection = key, 
+                    db = src$db, 
+                    url = src$url)
 
+  # check collection
+
+  # rights may be insufficient to call info(),
+  # hence try() blocks and consecutive tries 
+  tmp <- try(!is.null(test$con$info()$stats) &&
+               test$con$info()$stats$count != 0L,
+             silent = TRUE) 
+  if (!("try-error" %in% class(tmp))) return(tmp)
+
+  tmp <- try(docdb_query(src = test, 
+                         key = key, 
+                         query = '{"_id": {"$ne": ""}}', 
+                         limit = 1L),
+             silent = TRUE)
+  if (!("try-error" %in% class(tmp))) return(nrow(tmp) > 0L)
+}
+
 #' @export
 docdb_exists.src_sqlite <- function(src, key, ...) {
   assert(key, 'character')

R/get.R

@@ -3,7 +3,7 @@
 #' @export
 #' @import data.table jsonlite
 #' @param src source object, result of call to src
-#' @param key (chartacter) A key. ignored for mongo
+#' @param key (character) A key (collection for mongo)
 #' @param limit (integer) number of records/rows to return. by default
 #' not passed, so you get all results. Only works for CouchDB, 
 #' Elasticsearch and MongoDB; ignored for others
@@ -42,7 +42,7 @@
 #' docdb_get(src, "mtcars")
 #'
 #' # Mongo
-#' src <- src_mongo()
+#' src <- src_mongo(collection = "mtcars")
 #' docdb_create(src, "mtcars", mtcars)
 #' docdb_get(src, "mtcars")
 #' docdb_get(src, "mtcars", limit = 4)
@@ -94,11 +94,19 @@ docdb_get.src_redis <- function(src, key, limit = NULL, ...) {
 
 #' @export
 docdb_get.src_mongo <- function(src, key, limit = NULL, ...) {
+
+  # check expectations
+  if (exists("key", inherits = FALSE) && 
+      src$collection != key) 
+    message("Parameter 'key' is different from parameter 'collection', ",
+            "was given as ", src$collection, " in src_mongo().")
+
   # FIXME: or use $find() here? not if doing a separate query method
   if (!is.null(limit)) return(src$con$iterate(limit = limit)$page())
   dump <- tempfile()
   src$con$export(file(dump))
-  jsonlite::stream_in(file(dump), verbose = FALSE)
+  # remove first column, a mongodb identifier
+  jsonlite::stream_in(file(dump), verbose = FALSE) # [,-1]
 }
 
 #' @export
@@ -134,7 +142,7 @@ docdb_get.src_sqlite <- function(src, key, limit = NULL, ...) {
   # Because parsing huge JSON strings is difficult and inefficient, 
   # JSON streaming is done using lines of minified JSON records, a.k.a. ndjson. 
   jsonlite::stream_in(file(dump), verbose = FALSE)
-  
+
 }
 
 ## helpers --------------------------------------

R/query.R

@@ -2,7 +2,7 @@
 #'
 #' @export
 #' @param src source object, result of call to src
-#' @param key (chartacter) A key. ignored for mongo
+#' @param key (character) A key (collection for mongo)
 #' @param query various. see Query section below.
 #' @param ... Additional named parameters passed on to each package:
 #' 
@@ -53,7 +53,7 @@
 #' docdb_query(src, "iris", query = "Petal.Width:1.5")
 #'
 #' # Mongo
-#' src <- src_mongo()
+#' src <- src_mongo(collection = "mtcars")
 #' if (docdb_exists(src, "mtcars")) docdb_delete(src, "mtcars")
 #' docdb_create(src, "mtcars", mtcars)
 #' docdb_query(src, query = '{"mpg":21}')
@@ -96,7 +96,19 @@ docdb_query.src_elastic <- function(src, key, query, ...) {
 
 #' @export
 docdb_query.src_mongo <- function(src, key, query, ...) {
-  src$con$find(query = query, ...)
+
+  # check expectations
+  if (exists("key", inherits = FALSE) && 
+      src$collection != key) 
+    message("Parameter 'key' is different from parameter 'collection', ",
+            "was given as ", src$collection, " in src_mongo().")
+
+  # get results
+  tmp <- src$con$find(query = query, ...)
+
+  # ensure results are flattened
+  jsonlite::flatten(tmp)
+
 }
 
 #' @export

R/src_mongo.R

@@ -14,16 +14,30 @@
 #' }
 src_mongo <- function(collection = "test", db = "test",
                       url = "mongodb://localhost", ...) {
-
+  
   con <- mongolite::mongo(collection, db, url, ...)
-  structure(list(con = con, db = db), class = c("src_mongo", "docdb_src"))
+  structure(list(con = con, collection = collection, db = db, url = url), class = c("src_mongo", "docdb_src"))
 }
 
 #' @export
 print.src_mongo <- function(x, ...) {
-  con <- x$con
-  db <- x$db
-  srv <- con$info()
-  cat(sprintf("MongoDB %s (uptime: %ss)\nURL: %s/%s\n",
-              srv$server$version, srv$server$uptime, srv$server$host, db))
+  con  <- x$con
+  coll <- x$collection
+  db   <- x$db
+  url  <- x$url
+
+  # rights may be insufficient to call info(),
+  # hence try() block and fallback printout
+  tmp <- try({
+    srv <- con$info()
+    cat(sprintf("MongoDB %s (uptime: %ss)\nURL: %s/%s \nCollection: %s\n",
+                srv$server$version, srv$server$uptime, srv$server$host, db, coll))
+  }, 
+  silent = TRUE)
+
+  if ("try-error" %in% class(tmp)) {
+    cat(sprintf("MongoDB \nURL: %s/%s \nCollection: %s\n",
+                url, db, coll))
+
+  }
 }