Add a useful print method

Fixes #140

NAMESPACE

@@ -49,7 +49,6 @@ exportMethods(onValidate)
 exportMethods(poolCheckout)
 exportMethods(poolClose)
 exportMethods(poolReturn)
-exportMethods(show)
 exportMethods(sqlAppendTable)
 exportMethods(sqlCreateTable)
 exportMethods(sqlData)

R/DBI.R

@@ -20,6 +20,8 @@ NULL
 #' @examples
 #' # You use a dbPool in the same way as a standard DBI connection
 #' pool <- dbPool(RSQLite::SQLite())
+#' pool
+#'
 #' DBI::dbWriteTable(pool, "mtcars", mtcars)
 #' dbGetQuery(pool, "SELECT * FROM mtcars LIMIT 4")
 #'

R/pool-methods.R

@@ -83,17 +83,6 @@ setMethod("poolClose", "Pool", function(pool) {
   pool$close()
 })
 
-#' Show method
-#' @param object A Pool object.
-#' @export
-setMethod("show", "Pool", function(object) {
-  pooledObj <- poolCheckout(object)
-  on.exit(poolReturn(pooledObj))
-  cat("<Pool>\n", "  pooled object class: ",
-      is(pooledObj)[1], sep = "")
-})
-
-
 #' Return an object back to the pool
 #'
 #' Should be called by the end user if they previously fetched

R/pool.R

@@ -31,6 +31,8 @@ Pool <- R6::R6Class("Pool",
         self$validationInterval <- validationInterval
         self$state <- state
 
+        private$objClass <- NULL
+
         private$freeObjects <- new.env(parent = emptyenv())
 
         for (i in seq_len(self$minSize)) {
@@ -141,6 +143,15 @@ Pool <- R6::R6Class("Pool",
           "- they will be destroyed the next time the ",
           "garbage collector runs).", call. = FALSE)
       }
+    },
+
+    print = function(...) {
+      cat("<Pool> of ", private$objClass, " objects\n", sep = "")
+      cat("  Objects checked out: ", self$counters$taken, "\n", sep = "")
+      cat("  Available in pool: ", self$counters$free, "\n", sep = "")
+      cat("  Max size: ", self$maxSize, "\n", sep = "")
+      cat("  Valid: ", self$valid, "\n", sep = "")
+      invisible(self)
     }
   ),
 
@@ -149,6 +160,7 @@ Pool <- R6::R6Class("Pool",
     freeObjects = NULL,
     factory = NULL,
     idCounter = NULL,
+    objClass = NULL,
 
     ## creates an object, assigns it to the
     ## free environment and returns it
@@ -164,6 +176,10 @@ Pool <- R6::R6Class("Pool",
           "returns the object to be pooled.")
       }
 
+      if (is.null(private$objClass)) {
+        private$objClass <- class(object)
+      }
+
       ## attach metadata about the object
       pool_metadata <- new.env(parent = emptyenv())
       attr(object, "pool_metadata") <- pool_metadata

tests/testthat/_snaps/pool.md

@@ -0,0 +1,32 @@
+# pool has useful print method
+
+    Code
+      pool
+    Output
+      <Pool> of numeric objects
+        Objects checked out: 0
+        Available in pool: 1
+        Max size: Inf
+        Valid: TRUE
+    Code
+      x1 <- poolCheckout(pool)
+      x2 <- poolCheckout(pool)
+      pool
+    Output
+      <Pool> of numeric objects
+        Objects checked out: 2
+        Available in pool: 0
+        Max size: Inf
+        Valid: TRUE
+    Code
+      poolReturn(x1)
+      pool
+    Output
+      <Pool> of numeric objects
+        Objects checked out: 1
+        Available in pool: 1
+        Max size: Inf
+        Valid: TRUE
+    Code
+      poolReturn(x2)
+

tests/testthat/test-pool.R

@@ -58,4 +58,20 @@ describe("pool", {
   })
 })
 
+test_that("pool has useful print method", {
+  pool <- poolCreate(function() 10)
+  on.exit(poolClose(pool))
 
+  expect_snapshot({
+    pool
+
+    x1 <- poolCheckout(pool)
+    x2 <- poolCheckout(pool)
+    pool
+
+    poolReturn(x1)
+    pool
+
+    poolReturn(x2)
+  })
+})