add subset by tag, closes #305

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: simmer
 Type: Package
 Title: Discrete-Event Simulation for R
-Version: 4.4.6.8
+Version: 4.4.6.9
 Authors@R: c(
     person("Iñaki", "Ucar", email="[email protected]",
       role=c("aut", "cph", "cre"), comment=c(ORCID="0000-0001-6403-5550")),
@@ -24,6 +24,6 @@ Depends: R (>= 3.4.0)
 Imports: Rcpp, magrittr, codetools, utils
 Suggests: simmer.plot, parallel, testthat, knitr, rmarkdown, rticles
 LinkingTo: Rcpp (>= 0.12.9)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
 Roxygen: list(old_usage = TRUE)
 VignetteBuilder: knitr

NEWS.md

@@ -1,5 +1,11 @@
 # simmer devel
 
+## New features
+
+- Add support for subsetting by activity tag (#305).
+
+## Minor changes and fixes
+
 - Fix `set_source()` to avoid leaking arrivals from the old source (#322).
 - Fix sources to properly reset distributions and trajectories (#324).
 - Fix resources to properly reset initial parameters (#325).

R/simmer.R

@@ -1,5 +1,5 @@
 # Copyright (C) 2014 Bart Smeets
-# Copyright (C) 2017-2019 Iñaki Ucar
+# Copyright (C) 2017-2024 Iñaki Ucar
 #
 # This file is part of simmer.
 #
@@ -53,12 +53,11 @@
 #' vignette(package = "simmer")
 #' }
 #'
-#' @docType package
 #' @name simmer-package
 #'
 #' @useDynLib simmer, .registration=TRUE
 #' @importFrom Rcpp evalCpp
-NULL
+"_PACKAGE"
 
 #' @importFrom magrittr %>%
 #' @export

R/trajectory-methods.R

@@ -1,6 +1,6 @@
 # Copyright (C) 2014-2015 Bart Smeets
 # Copyright (C) 2015-2016 Bart Smeets and Iñaki Ucar
-# Copyright (C) 2016-2022 Iñaki Ucar
+# Copyright (C) 2016-2024 Iñaki Ucar
 #
 # This file is part of simmer.
 #
@@ -93,8 +93,8 @@
 trajectory <- function(name="anonymous", verbose=FALSE) {
   check_args(name="character", verbose="flag")
 
-  env <- list2env(list(
-    name=name, verbose=verbose, n_activities=0, names=NULL, ptrs=NULL))
+  env <- list2env(list(name=name, verbose=verbose, n_activities=0,
+                       names=NULL, tags=NULL, ptrs=NULL))
   env$head <- function() env$ptrs[[1]]
   env$tail <- function() env$ptrs[[length(env)]]
   env$clone <- function() subset.trajectory(env)
@@ -114,7 +114,7 @@ print.trajectory <- function(x, indent=0, verbose=x$verbose, ...) {
 
 add_activity <- function(x, activity, env.=parent.frame()) {
   tag <- env.$tag
-  if (!missing(tag)) {
+  if (missing(tag)) tag <- NA else {
     if (!is.character(tag))
       stop(get_caller(), ": 'tag' is not a valid character", call.=FALSE)
     activity_set_tag_(activity, tag)
@@ -123,6 +123,7 @@ add_activity <- function(x, activity, env.=parent.frame()) {
     activity_chain_(x$tail(), activity)
   x$ptrs <- c(x$ptrs, activity)
   x$names <- c(x$names, get_caller())
+  x$tags <- c(x$tags, tag)
   x$n_activities <- x$n_activities + activity_get_count_(activity)
   x
 }
@@ -136,7 +137,7 @@ get_parts <- function(x, i, double=FALSE) {
     if (is.logical(i)) {
       parts <- which(rep_len(i, length(x)))
     } else if (is.character(i)) {
-      parts <- which(x$names %in% i)
+      parts <- sort(unique(c(which(x$names %in% i), which(x$tags %in% i))))
       if (double) parts <- parts[[1]]
     } else if (is.numeric(i)) {
       i <- i[!is.na(i)]
@@ -163,6 +164,7 @@ subset.trajectory <- function(x, i, double=FALSE) {
     })
     mapply(activity_chain_, new$ptrs[-length(new$ptrs)], new$ptrs[-1])
     new$names <- x$names[parts]
+    new$tags <- x$tags[parts]
   }
   new
 }
@@ -195,8 +197,8 @@ replace.trajectory <- function(x, i, value, double=FALSE) {
 #' hence truncated towards zero). Negative integers indicate elements/slices to
 #' leave out the selection.
 #'
-#' Character vectors will be matched to the names of the activities in the
-#' trajectory as by \code{\link{\%in\%}}.
+#' Character vectors will be matched to the names and tags of the activities
+#' in the trajectory as by \code{\link{\%in\%}}.
 #'
 #' Logical vectors indicate elements/slices to select. Such vectors are recycled
 #' if necessary to match the corresponding extent.
@@ -328,6 +330,7 @@ join.trajectory <- function(...) {
 
     new$ptrs <- c(new$ptrs, i$ptrs)
     new$names <- c(new$names, i$names)
+    new$tags <- c(new$tags, i$tags)
     new$n_activities <- new$n_activities + i$n_activities
   }
   new

tests/testthat/test-trajectory.R

@@ -1,5 +1,5 @@
 # Copyright (C) 2015-2016 Iñaki Ucar and Bart Smeets
-# Copyright (C) 2016-2022 Iñaki Ucar
+# Copyright (C) 2016-2024 Iñaki Ucar
 #
 # This file is part of simmer.
 #
@@ -233,7 +233,7 @@ t0 <- trajectory(verbose = TRUE) %>%
 t1 <- trajectory(verbose = TRUE) %>%
   branch(function() 1, c(TRUE), t0) %>%
   join(t0) %>%
-  branch(function() 1, c(TRUE, TRUE, TRUE), t0, t0, t0) %>%
+  branch(function() 1, c(TRUE, TRUE, TRUE), t0, t0, t0, tag="foo") %>%
   join(t0) %>%
   branch(function() 1, c(TRUE, TRUE, TRUE, TRUE, TRUE), t0, t0, t0, t0, t0)
 
@@ -353,6 +353,9 @@ test_that("character subsetting with [ works as expected", {
   test <- t1["asdf"]
   expect_equal(length(test), 0)
   expect_equal(get_n_activities(test), 0)
+  test <- t1["foo"]
+  expect_equal(length(test), 1)
+  expect_equal(get_n_activities(test), 4)
 })
 
 test_that("character replacing with [ works as expected", {
@@ -364,6 +367,9 @@ test_that("character replacing with [ works as expected", {
   test["asdf"] <- t0
   expect_equal(length(test), 5)
   expect_equal(get_n_activities(test), 14)
+  test["foo"] <- t0
+  expect_equal(length(test), 5)
+  expect_equal(get_n_activities(test), 11)
 })
 
 test_that("integer subsetting with [[ works as expected", {