Add prune() method and extend test suite

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: hrqolr
 Title: Simulator of health-related quality of life trajectories
-Version: 0.0.0.9068
-Date: 2024-06-02
-Authors@R: 
+Version: 0.0.0.9083
+Date: 2024-06-14
+Authors@R:
 	c(person("Benjamin Skov", "Kaas-Hansen",
 	         email = "[email protected]",
 	         role = c("aut", "cre", "cph"),
@@ -11,11 +11,11 @@ Authors@R:
 	         email = "[email protected]",
 	         role = c("aut"),
 	         comment = c(ORCID = "0000-0001-5799-7655")))
-Description: hrqolr simulates randomised clinical trials with temporal 
-	trajectories of health-related quality of life (HRQoL) as the outcome and quantifies effect 
-	sizes as single-sampled HRQoL values at end of follow-up and as the area under the trajectories. 
-	Developed as part of the INCEPT (Intensive Care Platform Trial) project (<https://incept.dk/>), 
-	which is primarily supported by a grant from Sygeforsikringen "danmark" 
+Description: hrqolr simulates randomised clinical trials with temporal
+	trajectories of health-related quality of life (HRQoL) as the outcome and quantifies effect
+	sizes as single-sampled HRQoL values at end of follow-up and as the area under the trajectories.
+	Developed as part of the INCEPT (Intensive Care Platform Trial) project (<https://incept.dk/>),
+	which is primarily supported by a grant from Sygeforsikringen "danmark"
 	(<https://www.sygeforsikring.dk/>).
 Type: Package
 BugReports: https://github.com/INCEPTdk/hrqolr/issues
@@ -26,7 +26,7 @@ Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.1
-Depends: 
+Depends:
 	R (>= 2.10)
 Imports:
 	fastmap (>= 1.2.0),

R/cache_hrqolr.R

@@ -8,8 +8,11 @@
 #' @export
 #' @importFrom utils assignInMyNamespace
 #'
-cache_hrqolr <- function(max_size = 2 * 1024^3) {
-	utils::assignInMyNamespace(".hrqolr_cache_user", in_memory_cache(max_size))
+cache_hrqolr <- function(max_size = 2 * 1024^3, pruning_factor = 0.5) {
+	utils::assignInMyNamespace(
+		".hrqolr_cache_user",
+		in_memory_cache(max_size, pruning_factor)
+	)
 }
 
 
@@ -27,23 +30,29 @@ clear_hrqolr_cache <- function() {
 #' overhead due to housekeeping as this is an internal function that users
 #' should never use.
 #'
-#' @param max_size Maximum size of the cache, in bytes. If the cache exceeds
-#'   this size, the entire cache is wiped; this is much faster than using an
-#'   eviction policy for how the cache is used in `hrqolr` objects will be
-#'   removed according to the value of the
+#' @param max_size number, maximum size of the cache, in bytes. If the cache
+#'   exceeds this size, the entire cache is wiped; this is much faster than
+#'   using an eviction policy for how the cache is used in `hrqolr` objects will
+#'   be removed according to the value of the
+#' @param pruning_factor number, the fraction of elements to remove from the
+#'   cache when it's full.
 #'
 #' @importFrom utils object.size
 #' @importFrom rlang as_quosure eval_tidy
 #' @keywords internal
 #'
 #' @return A memory caching object, with class `hrqolr_memory_cache`.
 #'
-in_memory_cache <- function(max_size = 2 * 1024^3) {
+in_memory_cache <- function(max_size = 2 * 1024^3, pruning_factor = 0.5) {
 	if (!verify_num(max_size)) {
 		stop0("max_size must be a number. Use `Inf` for no limit.")
 	}
 
-	key_idx_map_  <- fastmap::fastmap()
+	if (!verify_num(pruning_factor, min_value = 0, max_value = 1)) {
+		stop0("pruning_factor must be a number between 0 and 1.")
+	}
+
+	key_idx_map_ <- fastmap::fastmap()
 
 	# These values are set in the reset() method.
 	key_ <- NULL
@@ -58,20 +67,41 @@ in_memory_cache <- function(max_size = 2 * 1024^3) {
 	# Internal dynamic metadata
 	total_size_ <- 0  # Total number of bytes used
 	max_total_size_ <- 0  # The largest cache size in bytes, can be useful if pruned
+	n_pruned_ <- 0L  # The number of times the cache was reset
 	last_idx_ <- 0L  # Most recent (and largest) index used
 
 	# Methods
 	reset <- function() {
 		key_idx_map_$reset()
-		key_ <<- rep_len(NA_character_, initial_size)
-		value_ <<- vector("list", initial_size)
-		size_ <<- rep_len(NA_real_, initial_size)
-
-		# Update before resetting
-		max_total_size_ <<- max(max_total_size_, total_size_)
+		key_ <<- vector("character")
+		value_ <<- vector("list")
+		size_ <<- vector("numeric")
 
 		total_size_ <<- 0
 		last_idx_ <<- 0L
+
+		gc()
+		invisible(TRUE)
+	}
+
+	prune <- function() {
+		to_keep <- seq_along(key_) >= (pruning_factor * length(key_))
+
+		idx_to_keep <- unlist(key_idx_map_$mget(key_[to_keep]))
+		key_ <<- key_[idx_to_keep]
+		value_ <<- value_[idx_to_keep]
+		size_ <<- size_[idx_to_keep]
+
+		# We have to re-initialise the key-idx map
+		key_idx_map_ <<- fastmap::fastmap()
+		key_idx_map_$mset(.list = setNames(seq_along(key_), key_))
+
+		max_total_size_ <<- max(max_total_size_, total_size_)
+		total_size_ <<- sum(size_)
+		last_idx_ <<- length(key_)
+		n_pruned_ <<- n_pruned_ + 1
+
+		gc()
 		invisible(TRUE)
 	}
 
@@ -88,11 +118,6 @@ in_memory_cache <- function(max_size = 2 * 1024^3) {
 	set <- function(key, value) {
 		if (prune_by_size) {
 			size <- as.numeric(object.size(value))  # imperfect, see ?object.size
-
-			if ((total_size_ + size) > max_size_) {
-				reset()
-			}
-
 			total_size_ <<- total_size_ + size
 		} else {
 			size <- NA_real_
@@ -112,9 +137,13 @@ in_memory_cache <- function(max_size = 2 * 1024^3) {
 			new_idx <- last_idx_
 		}
 
-		key_  [new_idx]   <<- key
+		key_[new_idx] <<- key
 		value_[[new_idx]] <<- value
-		size_ [new_idx]   <<- size
+		size_[new_idx] <<- size
+
+		if (total_size_ > max_size_) {
+			prune()
+		}
 
 		invisible(TRUE)
 	}
@@ -124,13 +153,11 @@ in_memory_cache <- function(max_size = 2 * 1024^3) {
 	}
 
 	info <- function(x = NULL) {
-		options <- lapply(
-			list(
-				max_size = max_size_,
-				total_size = total_size_,
-				max_total_size = max(max_total_size_, total_size_)
-			),
-			function(o) structure(o, class = c("hrqolr_bytes", class(o)))
+		options <- list(
+			max_size = structure(max_size_, class = "hrqolr_bytes"),
+			total_size = structure(total_size_, class = "hrqolr_bytes"),
+			max_total_size = structure(max(max_total_size_, total_size_), class = "hrqolr_bytes"),
+			n_pruned = n_pruned_
 		)
 
 		if (is.null(x)) {
@@ -151,7 +178,8 @@ in_memory_cache <- function(max_size = 2 * 1024^3) {
 			set = set,
 			keys = keys,
 			info = info,
-			reset = reset
+			reset = reset,
+			prune = prune
 		),
 		class = c("hrqolr_memory_cache")
 	)

R/plot.R

@@ -91,12 +91,13 @@ plot.hrqolr_trajectories <- function(
 #'
 #' @param analysis character, `"all"` (include non-survivors and set their HRQoL to 0) or `"survivors"`.
 #' @param ecdf logical, whether to plot the empiricial cumulative distribution (default) or not
+#' @inheritParams stats::density
 #'
 #' @import data.table
 #' @export
 #' @describeIn plot Single trial
 #'
-plot.hrqolr_trial <- function(x, analysis = "all", ecdf = TRUE, ...) {
+plot.hrqolr_trial <- function(x, analysis = "all", ecdf = TRUE, n = 512, ...) {
 	assert_pkgs("ggplot2")
 	x <- copy(x$patient_results) # don't corrupt input object
 
@@ -111,19 +112,23 @@ plot.hrqolr_trial <- function(x, analysis = "all", ecdf = TRUE, ...) {
 
 	p_base <- ggplot2::ggplot(dt, ggplot2::aes(x = value, colour = arm)) +
 		ggplot2::facet_wrap(~ variable, scales = "free") +
-		ggplot2::theme(legend.title = ggplot2::element_blank())
+		ggplot2::theme(
+			legend.title = ggplot2::element_blank(),
+			axis.title.x = ggplot2::element_blank()
+		)
 
 	if (isTRUE(ecdf)) {
 		p_base +
-			ggplot2::stat_ecdf(na.rm = TRUE, pad = FALSE) +
-			ggplot2::scale_y_continuous(labels = scales::percent)
+			ggplot2::stat_ecdf(geom = "line", position = "identity", na.rm = TRUE, pad = TRUE) +
+			ggplot2::scale_y_continuous(labels = scales::percent) +
+			ggplot2::labs(y = "Cumulative density")
 	} else {
 		p_base +
-			ggplot2::stat_density(geom = "line", position = "identity", na.rm = TRUE, trim = TRUE) +
+			ggplot2::stat_density(geom = "line", position = "identity", na.rm = TRUE) +
 			ggplot2::theme(
 				axis.text.y = ggplot2::element_blank(),
 				axis.ticks.y = ggplot2::element_blank()
-			)
+			) +
+			ggplot2::labs(y = "Density")
 	}
-
 }

R/print.R

@@ -230,6 +230,11 @@ print.hrqolr_summary_stats <- function(x, decimals = 3, ...) {
 #' @rdname print
 #'
 print.hrqolr_bytes <- function (x, digits = 3, ...) {
+	if (length(x) > 1) {
+		sapply(x, print.hrqolr_bytes)
+		return(invisible(x))
+	}
+
 	if (is.na(x)) {
 		cat("Not available\n")
 

tests/testthat/_snaps/after_pruning/caching.md

@@ -0,0 +1,18 @@
+# Caching works
+
+    Code
+      cache$info()
+    Output
+      $max_size
+      10 kB
+
+      $total_size
+      8.1 kB
+
+      $max_total_size
+      12.1 kB
+
+      $n_pruned
+      [1] 1
+
+

tests/testthat/_snaps/after_reassign/caching.md

@@ -0,0 +1,18 @@
+# Caching works
+
+    Code
+      cache$info()
+    Output
+      $max_size
+      10.2 kB
+
+      $total_size
+      4.1 kB
+
+      $max_total_size
+      12.1 kB
+
+      $n_pruned
+      [1] 1
+
+

tests/testthat/_snaps/after_reset/caching.md

@@ -7,9 +7,12 @@
       10.2 kB
 
       $total_size
-      4.05 kB
+      8.1 kB
 
       $max_total_size
-      8.1 kB
+      12.1 kB
+
+      $n_pruned
+      [1] 1
 
 

tests/testthat/_snaps/before_pruning/caching.md

@@ -0,0 +1,18 @@
+# Caching works
+
+    Code
+      cache$info()
+    Output
+      $max_size
+      10 kB
+
+      $total_size
+      8.1 kB
+
+      $max_total_size
+      8.1 kB
+
+      $n_pruned
+      [1] 0
+
+