Add new $<- method

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method("$<-",linelist)
 S3method("[",linelist)
 S3method("[<-",linelist)
 S3method("[[<-",linelist)

NEWS.md

@@ -1,5 +1,18 @@
 # linelist (development version)
 
+## New features
+
+* linelist objects now have a new custom `$<-.linelist()` to prevent tag loss
+when subsetting a linelist object (@Bisaloo, #86). This completes the
+functionality already provided by the `[<-.linelist()` and `[[<-.linelist()`
+methods.
+
+  ```r
+  x$tagged_column <- NULL
+  #> Warning in prune_tags(out, lost_action): The following tags have lost their variable:
+  #>  tag:tagged_column
+  ```
+
 # linelist 1.0.0
 
 ## New features

R/square_bracket.R

@@ -5,18 +5,15 @@
 #' takes the appropriate action if this is the case (warning, error, or ignore,
 #' depending on the general option set via [lost_tags_action()]) .
 #'
+#' @inheritParams base::Extract
 #' @param x a `linelist` object
-#'
 #' @param i a vector of `integer` or `logical` to subset the rows of the
 #'   `linelist`
-#'
 #' @param j a vector of `character`, `integer`, or `logical` to subset the
 #'   columns of the `linelist`
-#'
 #' @param drop a `logical` indicating if, when a single column is selected, the
 #'   `data.frame` class should be dropped to return a simple vector, in which
 #'   case the `linelist` class is lost as well; defaults to `FALSE`
-#'
 #' @param value the replacement to be used for the entries identified in `x`
 #'
 #' @return If no drop is happening, a `linelist`. Otherwise an atomic vector.
@@ -56,6 +53,9 @@
 #'
 #'   x[[2]] <- NULL
 #'   x
+#'
+#'   x$age <- NULL
+#'   x
 #' }
 `[.linelist` <- function(x, i, j, drop = FALSE) {
   # Strategy for subsetting
@@ -97,7 +97,7 @@
   }
 
   # Case 2
-  old_tags <- tags(x, TRUE)
+  old_tags <- tags(x, show_null = TRUE)
   out <- restore_tags(out, old_tags, lost_action)
 
   out
@@ -110,7 +110,7 @@
 `[<-.linelist` <- function(x, i, j, value) {
   lost_action <- get_lost_tags_action()
   out <- NextMethod()
-  old_tags <- tags(x, TRUE)
+  old_tags <- tags(x, show_null = TRUE)
   out <- restore_tags(out, old_tags, lost_action)
   out
 }
@@ -122,7 +122,18 @@
 `[[<-.linelist` <- function(x, i, j, value) {
   lost_action <- get_lost_tags_action()
   out <- NextMethod()
-  old_tags <- tags(x, TRUE)
+  old_tags <- tags(x, show_null = TRUE)
+  out <- restore_tags(out, old_tags, lost_action)
+  out
+}
+
+#' @export
+#'
+#' @rdname sub_linelist
+`$<-.linelist` <- function(x, name, value) {
+  lost_action <- get_lost_tags_action()
+  out <- NextMethod()
+  old_tags <- tags(x, show_null = TRUE)
   out <- restore_tags(out, old_tags, lost_action)
   out
 }

tests/testthat/test-prune_tags.R

@@ -5,8 +5,7 @@ test_that("tests for prune_tags", {
   msg <- "Must inherit from class 'linelist', but has class 'data.frame'."
   expect_error(prune_tags(cars), msg)
 
-  x$speed <- NULL
-  attr(x, "names") <- "belette" # hack needed as names<- is now safe
+  attr(x, "names") <- c("new1", "new2") # hack needed as names<- is now safe
   msg <- paste(
     "The following tags have lost their variable:",
     " date_onset:dist, age:speed",

tests/testthat/test-square_bracket.R

@@ -97,3 +97,31 @@ test_that("tests for [[<- operator", {
   x[[1]] <- NULL
   expect_identical(ncol(x), 0L)
 })
+
+test_that("$<- operator detects tag loss", {
+
+  # errors
+  lost_tags_action("warning", quiet = TRUE)
+  x <- make_linelist(cars, id = "speed", age = "dist")
+  msg <- "The following tags have lost their variable:\n id:speed"
+  expect_warning(x$speed <- NULL, msg)
+
+  lost_tags_action("error", quiet = TRUE)
+  x <- make_linelist(cars, id = "speed", age = "dist")
+  msg <- "The following tags have lost their variable:\n id:speed"
+  expect_error(x$speed <- NULL, msg)
+
+  lost_tags_action("none", quiet = TRUE)
+  x <- make_linelist(cars, id = "speed", age = "dist")
+  x$speed <- NULL
+  x$dist <- NULL
+  expect_identical(ncol(x), 0L)
+})
+
+test_that("$<- allows innocuous tag modification", {
+
+  x <- make_linelist(cars, id = "speed", age = "dist")
+  expect_no_condition(x$speed <- 1L)
+  expect_identical(x$speed, rep(1L, nrow(x)))
+
+})