Add a useful print method (#144)

Fixes #140

NAMESPACE

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

NEWS.md

@@ -1,5 +1,7 @@
 # pool (development version)
 
+* Pools now get a useful print method (#140).
+
 * `dbPool()`'s `validateQuery` is now actually used (#153).
 
 * Connections are now validated once on first checkout to ensure that the

R/DBI-custom.R

@@ -59,15 +59,13 @@ setMethod("dbDisconnect", "Pool", function(conn, ...) {
 #' @export
 #' @rdname DBI-custom
 setMethod("dbGetInfo", "Pool", function(dbObj, ...) {
- pooledObj <- poolCheckout(dbObj)
- on.exit(poolReturn(pooledObj))
  list(
  class = is(dbObj),
  valid = dbObj$valid,
  minSize = dbObj$minSize,
  maxSize = dbObj$maxSize,
  idleTimeout = dbObj$idleTimeout,
- pooledObjectClass = is(pooledObj)[1],
+ pooledObjectClass = dbObj$objClass[[1]],
  numberFreeObjects = dbObj$counters$free,
  numberTakenObjects = dbObj$counters$taken
  )

R/DBI.R

@@ -17,6 +17,8 @@
 #' @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

@@ -104,16 +104,3 @@ setMethod("poolReturn", "ANY", function(object) {
  pool <- pool_metadata(object)$pool
  pool$release(object)
 })
-
-
-#' 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 = "")
-})
-
-

R/pool.R

@@ -2,6 +2,7 @@
 Pool <- R6::R6Class("Pool",
  public = list(
 
+ objClass = NULL,
  valid = NULL,
  counters = NULL,
  minSize = NULL,
@@ -31,6 +32,8 @@ Pool <- R6::R6Class("Pool",
  self$validationInterval <- validationInterval
  self$state <- state
 
+ self$objClass <- NULL
+
  private$freeObjects <- new.env(parent = emptyenv())
 
  for (i in seq_len(self$minSize)) {
@@ -145,6 +148,15 @@ Pool <- R6::R6Class("Pool",
  "Use `poolReturn()` them to the pool so they can be destroyed."
  ))
  }
+ },
+
+ print = function(...) {
+ cat("<Pool> of ", self$objClass %||% "unknown", " 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)
  }
  ),
 
@@ -172,6 +184,10 @@ Pool <- R6::R6Class("Pool",
  )
  }
 
+ if (is.null(self$objClass)) {
+ self$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

@@ -6,3 +6,46 @@
   Error in `poolCheckout()`:
   ! Maximum number of objects in pool has been reached
 
+# 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)
+
+# empty pool has useful print method
+
+ Code
+  pool
+ Output
+  <Pool> of unknown objects
+  Objects checked out: 0
+  Available in pool: 0
+  Max size: Inf
+  Valid: TRUE
+

tests/testthat/test-pool.R

@@ -62,4 +62,29 @@ 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)
+ })
+})
+
+test_that("empty pool has useful print method", {
+ pool <- poolCreate(function() 10, minSize = 0)
+ on.exit(poolClose(pool))
+
+ expect_snapshot({
+ pool
+ })
+})