From 10888e3507795a09cc29370c7e0d4ed229fd1318 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Thu, 22 Sep 2022 14:41:32 +0200
Subject: [PATCH 1/5] Use switch to clarify control flow

---
 R/deprecate.R | 43 +++++++++++++++++++++++--------------------
 1 file changed, 23 insertions(+), 20 deletions(-)

diff --git a/R/deprecate.R b/R/deprecate.R
index 1596fcf..557b63a 100644
--- a/R/deprecate.R
+++ b/R/deprecate.R
@@ -102,18 +102,19 @@ deprecate_soft <- function(when,
   signal_stage("deprecated", what)
 
   verbosity <- lifecycle_verbosity()
-  if (verbosity == "quiet") {
-    NULL
-  } else if (verbosity %in% c("warning", "default")) {
-    if (is_direct(user_env)) {
-      always <- verbosity == "warning"
-      deprecate_warn0(msg, id, trace_back(bottom = caller_env()), always = always)
-    }
-  } else if (verbosity == "error") {
-    deprecate_stop0(msg)
-  }
 
-  invisible(NULL)
+  invisible(switch(
+    verbosity,
+    quiet = NULL,
+    error = deprecate_stop0(msg),
+    warning = ,
+    default =
+      if (is_direct(user_env)) {
+        always <- verbosity == "warning"
+        trace <- trace_back(bottom = caller_env())
+        deprecate_warn0(msg, id, trace, always = always)
+      }
+  ))
 }
 
 #' @rdname deprecate_soft
@@ -133,16 +134,18 @@ deprecate_warn <- function(when,
   signal_stage("deprecated", what)
 
   verbosity <- lifecycle_verbosity()
-  if (verbosity == "quiet") {
-    NULL
-  } else if (verbosity %in% c("default", "warning")) {
-    always <- always || verbosity == "warning"
-    deprecate_warn0(msg, id, trace_back(bottom = caller_env()), always = always)
-  } else if (verbosity == "error") {
-    deprecate_stop0(msg)
-  }
 
-  invisible(NULL)
+  invisible(switch(
+    verbosity,
+    quiet = NULL,
+    error = deprecate_stop0(msg),
+    warning = ,
+    default = {
+      always <- always || verbosity == "warning"
+      trace <- trace_back(bottom = caller_env())
+      deprecate_warn0(msg, id, trace, always = always)
+    }
+  ))
 }
 
 #' @rdname deprecate_soft

From 598384b3c0d952e07ad5d39d9e2ec3ea92df71ce Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Thu, 22 Sep 2022 15:04:29 +0200
Subject: [PATCH 2/5] Never warn repeatedly in indirect usages

---
 NEWS.md                            | 11 ++++++----
 R/deprecate.R                      |  5 +++--
 man/deprecate_soft.Rd              |  3 ++-
 tests/testthat/_snaps/deprecate.md | 13 +++++++----
 tests/testthat/helper-lifecycle.R  | 11 +++++++++-
 tests/testthat/helper-zeallot.R    | 34 +++++++++++++++++++++++++++++
 tests/testthat/test-deprecate.R    | 35 ++++++++++++++++++++----------
 7 files changed, 89 insertions(+), 23 deletions(-)
 create mode 100644 tests/testthat/helper-zeallot.R

diff --git a/NEWS.md b/NEWS.md
index b7053bb..181d841 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,13 +1,16 @@
 # lifecycle (development version)
 
+* Indirect usages of `deprecate_warn()` no longer warn repeatedly,
+  even if `always = TRUE` (#135).
+
 * In tests, `deprecate_soft()` will only warn if the deprecated function
   is called directly from the package being tested, not one of its dependencies.
-  This ensures that you only see the warning when it's your responsibility to 
+  This ensures that you only see the warning when it's your responsibility to
   do something about it (#134).
-  
-* `deprecate_soft()` will never warn when called on CRAN, ensuring that soft 
+
+* `deprecate_soft()` will never warn when called on CRAN, ensuring that soft
   deprecation will never break a reverse dependency (#134).
-  
+
 * Soft deprecations now only warn every 8 hours in non-package code (#134).
 
 # lifecycle 1.0.2
diff --git a/R/deprecate.R b/R/deprecate.R
index 557b63a..287a24c 100644
--- a/R/deprecate.R
+++ b/R/deprecate.R
@@ -128,7 +128,8 @@ deprecate_warn <- function(when,
                            details = NULL,
                            id = NULL,
                            always = FALSE,
-                           env = caller_env()) {
+                           env = caller_env(),
+                           user_env = caller_env(2)) {
   msg <- NULL # trick R CMD check
   msg %<~% lifecycle_message(when, what, with, details, env, "deprecate_warn")
   signal_stage("deprecated", what)
@@ -141,7 +142,7 @@ deprecate_warn <- function(when,
     error = deprecate_stop0(msg),
     warning = ,
     default = {
-      always <- always || verbosity == "warning"
+      always <- (always || verbosity == "warning") && is_direct(user_env)
       trace <- trace_back(bottom = caller_env())
       deprecate_warn0(msg, id, trace, always = always)
     }
diff --git a/man/deprecate_soft.Rd b/man/deprecate_soft.Rd
index 53dc7f3..3e6f833 100644
--- a/man/deprecate_soft.Rd
+++ b/man/deprecate_soft.Rd
@@ -23,7 +23,8 @@ deprecate_warn(
   details = NULL,
   id = NULL,
   always = FALSE,
-  env = caller_env()
+  env = caller_env(),
+  user_env = caller_env(2)
 )
 
 deprecate_stop(when, what, with = NULL, details = NULL, env = caller_env())
diff --git a/tests/testthat/_snaps/deprecate.md b/tests/testthat/_snaps/deprecate.md
index 6e28ea7..aad99c8 100644
--- a/tests/testthat/_snaps/deprecate.md
+++ b/tests/testthat/_snaps/deprecate.md
@@ -1,25 +1,30 @@
 # deprecate_warn() only warns repeatedly if always = TRUE
 
     Code
-      deprecate()
+      direct()
     Condition
       Warning:
       `foo()` was deprecated in lifecycle 1.0.0.
     Code
-      deprecate()
+      direct()
+      indirect()
+      indirect()
 
 ---
 
     Code
-      deprecate(always = TRUE)
+      direct(always = TRUE)
     Condition
       Warning:
       `foo()` was deprecated in lifecycle 1.0.0.
     Code
-      deprecate(always = TRUE)
+      direct(always = TRUE)
     Condition
       Warning:
       `foo()` was deprecated in lifecycle 1.0.0.
+    Code
+      indirect(always = TRUE)
+      indirect(always = TRUE)
 
 # what deprecation messages are readable
 
diff --git a/tests/testthat/helper-lifecycle.R b/tests/testthat/helper-lifecycle.R
index 3a088ae..f954960 100644
--- a/tests/testthat/helper-lifecycle.R
+++ b/tests/testthat/helper-lifecycle.R
@@ -1,4 +1,3 @@
-
 expect_lifecycle_defunct <- function(object, ...) {
   expect_error(object, class = "defunctError")
 }
@@ -29,3 +28,13 @@ spec_data <- function(fn = NULL,
     from = from
   )
 }
+
+new_callers <- function(deprecated_feature, env = caller_env()) {
+  direct <- inject(function(...) (!!deprecated_feature)(...))
+  indirect <- inject(function(...) (!!deprecated_feature)(...))
+
+  environment(direct) <- global_env()
+  environment(indirect) <- ns_env("base")
+
+  list(direct, indirect)
+}
diff --git a/tests/testthat/helper-zeallot.R b/tests/testthat/helper-zeallot.R
new file mode 100644
index 0000000..823799a
--- /dev/null
+++ b/tests/testthat/helper-zeallot.R
@@ -0,0 +1,34 @@
+# nocov start --- compat-zeallot --- 2020-11-23
+
+# This drop-in file implements a simple version of zeallot::`%<-%`.
+# Please find the most recent version in rlang's repository.
+
+
+`%<-%` <- function(lhs, value) {
+  lhs <- substitute(lhs)
+  env <- caller_env()
+
+  if (!is_call(lhs, "c")) {
+    abort("The left-hand side of `%<-%` must be a call to `c()`.")
+  }
+
+  vars <- as.list(lhs[-1])
+
+  if (length(value) != length(vars)) {
+    abort("The left- and right-hand sides of `%<-%` must be the same length.")
+  }
+
+  for (i in seq_along(vars)) {
+    var <- vars[[i]]
+    if (!is_symbol(var)) {
+      abort(paste0("Element ", i, " of the left-hand side of `%<-%` must be a symbol."))
+    }
+
+    env[[as_string(var)]] <- value[[i]]
+  }
+
+  invisible(value)
+}
+
+
+# nocov end
diff --git a/tests/testthat/test-deprecate.R b/tests/testthat/test-deprecate.R
index 7dfd49a..5c48e66 100644
--- a/tests/testthat/test-deprecate.R
+++ b/tests/testthat/test-deprecate.R
@@ -4,8 +4,13 @@ test_that("default deprecations behave as expected", {
   on.exit(env_unbind(deprecation_env, "test"))
   local_options(lifecycle_verbosity = "default")
 
-  expect_warning(deprecate_warn("1.0.0", "foo()", id = "test"), class = "lifecycle_warning_deprecated")
-  expect_warning(deprecate_warn("1.0.0", "foo()", id = "test"), NA)
+  deprecated_feature <- function(...) deprecate_warn("1.0.0", "foo()", id = "test", ...)
+  c(direct, indirect) %<-% new_callers(deprecated_feature)
+
+  expect_warning(direct(), class = "lifecycle_warning_deprecated")
+  expect_warning(indirect(), NA)
+  expect_warning(indirect(), NA)
+
   expect_defunct(deprecate_stop("1.0.0", "foo()"))
 })
 
@@ -13,18 +18,21 @@ test_that("deprecate_warn() only warns repeatedly if always = TRUE", {
   on.exit(env_unbind(deprecation_env, "test"))
   local_options(lifecycle_verbosity = "default")
 
-  deprecate <- function(...) {
-    deprecate_warn("1.0.0", "foo()", id = "test", ...)
-  }
+  deprecated_feature <- function(...) deprecate_warn("1.0.0", "foo()", id = "test", ...)
+  c(direct, indirect) %<-% new_callers(deprecated_feature)
 
   expect_snapshot({
-    deprecate()
-    deprecate()
+    direct()
+    direct()
+    indirect()
+    indirect()
   })
 
   expect_snapshot({
-    deprecate(always = TRUE)
-    deprecate(always = TRUE)
+    direct(always = TRUE)
+    direct(always = TRUE)
+    indirect(always = TRUE)
+    indirect(always = TRUE)
   })
 })
 
@@ -79,10 +87,15 @@ test_that("soft deprecation uses correct calling envs", {
 test_that("warning conditions are signaled only once if warnings are suppressed", {
   local_options(lifecycle_verbosity = "warning")
 
+  deprecated_feature <- function(...) deprecate_warn(...)
+  c(direct, indirect) %<-% new_callers(deprecated_feature)
+
   x <- 0L
   suppressWarnings(withCallingHandlers(
-    warning = function(...) x <<- x + 1L,
-    deprecate_warn("1.0.0", "foo()")
+    warning = function(...) x <<- x + 1L, {
+      direct("1.0.0", "foo()")
+      indirect("1.0.0", "foo()")
+    }
   ))
 
   expect_identical(x, 1L)

From e00dbad316f1e3d68f08c5193d3ac014caa301d7 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Thu, 22 Sep 2022 15:47:42 +0200
Subject: [PATCH 3/5] Recommend contacting authors

Closes #135
---
 NEWS.md                            |  4 +++
 R/deprecate.R                      | 52 ++++++++++++++++++++++++++----
 tests/testthat/_snaps/deprecate.md | 10 ++++++
 tests/testthat/test-deprecate.R    | 12 +++++++
 4 files changed, 72 insertions(+), 6 deletions(-)

diff --git a/NEWS.md b/NEWS.md
index 181d841..b558042 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -1,5 +1,9 @@
 # lifecycle (development version)
 
+* Indirect usages of deprecated features now mention the package that
+  likely used the deprecated feature and recommends contacting the
+  authors (#135).
+
 * Indirect usages of `deprecate_warn()` no longer warn repeatedly,
   even if `always = TRUE` (#135).
 
diff --git a/R/deprecate.R b/R/deprecate.R
index 287a24c..bfb72bf 100644
--- a/R/deprecate.R
+++ b/R/deprecate.R
@@ -102,6 +102,7 @@ deprecate_soft <- function(when,
   signal_stage("deprecated", what)
 
   verbosity <- lifecycle_verbosity()
+  direct <- is_direct(user_env)
 
   invisible(switch(
     verbosity,
@@ -109,10 +110,17 @@ deprecate_soft <- function(when,
     error = deprecate_stop0(msg),
     warning = ,
     default =
-      if (is_direct(user_env)) {
+      if (direct) {
         always <- verbosity == "warning"
         trace <- trace_back(bottom = caller_env())
-        deprecate_warn0(msg, id, trace, always = always)
+        deprecate_warn0(
+          msg,
+          id,
+          trace,
+          always = always,
+          direct = TRUE,
+          user_env = user_env
+        )
       }
   ))
 }
@@ -142,9 +150,17 @@ deprecate_warn <- function(when,
     error = deprecate_stop0(msg),
     warning = ,
     default = {
-      always <- (always || verbosity == "warning") && is_direct(user_env)
+      direct <- is_direct(user_env)
+      always <- direct && (always || verbosity == "warning")
       trace <- trace_back(bottom = caller_env())
-      deprecate_warn0(msg, id, trace, always = always)
+      deprecate_warn0(
+        msg,
+        id,
+        trace,
+        always = always,
+        direct = direct,
+        user_env = user_env
+      )
     }
   ))
 }
@@ -168,7 +184,9 @@ deprecate_warn0 <- function(msg,
                             id = NULL,
                             trace = NULL,
                             always = FALSE,
-                            call = caller_env()) {
+                            direct = FALSE,
+                            call = caller_env(),
+                            user_env = caller_env(2)) {
   id <- id %||% msg
   if (!always && !needs_warning(id, call = call)) {
     return()
@@ -178,12 +196,34 @@ deprecate_warn0 <- function(msg,
   env_poke(deprecation_env, id, Sys.time())
 
   footer <- function(...) {
+    footer <- NULL
+
+    if (!direct) {
+      top <- topenv(user_env)
+
+      if (is_namespace(top)) {
+        pkg <- ns_env_name(top)
+        footer <- c(
+          footer,
+          "i" = cli::format_inline(
+            "The deprecated feature was likely used in the {.pkg {pkg}} package."
+          ),
+          " " = cli::format_inline(
+            "Please report the issue to the authors."
+          )
+        )
+      }
+    }
+
     if (is_interactive()) {
-      c(
+      footer <- c(
+        footer,
         if (!always) silver("This warning is displayed once every 8 hours."),
         silver("Call `lifecycle::last_lifecycle_warnings()` to see where this warning was generated.")
       )
     }
+
+    footer
   }
   wrn <- new_deprecated_warning(msg, trace, footer = footer)
 
diff --git a/tests/testthat/_snaps/deprecate.md b/tests/testthat/_snaps/deprecate.md
index aad99c8..1f88c57 100644
--- a/tests/testthat/_snaps/deprecate.md
+++ b/tests/testthat/_snaps/deprecate.md
@@ -26,6 +26,16 @@
       indirect(always = TRUE)
       indirect(always = TRUE)
 
+# indirect usage recommends contacting authors
+
+    Code
+      indirect()
+    Condition
+      Warning:
+      `foo()` was deprecated in lifecycle 1.0.0.
+      i The deprecated feature was likely used in the base package.
+        Please report the issue to the authors.
+
 # what deprecation messages are readable
 
     Code
diff --git a/tests/testthat/test-deprecate.R b/tests/testthat/test-deprecate.R
index 5c48e66..13e3c10 100644
--- a/tests/testthat/test-deprecate.R
+++ b/tests/testthat/test-deprecate.R
@@ -36,6 +36,18 @@ test_that("deprecate_warn() only warns repeatedly if always = TRUE", {
   })
 })
 
+test_that("indirect usage recommends contacting authors", {
+  on.exit(env_unbind(deprecation_env, "test"))
+  local_options(lifecycle_verbosity = "default")
+
+  deprecated_feature <- function(...) deprecate_warn("1.0.0", "foo()", id = "test", ...)
+  c(direct, indirect) %<-% new_callers(deprecated_feature)
+
+  expect_snapshot({
+    indirect()
+  })
+})
+
 test_that("quiet suppresses _soft and _warn", {
   local_options(lifecycle_verbosity = "quiet")
 

From 6febf959c19095f7334592b0408b355aea4729b6 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Thu, 22 Sep 2022 18:34:04 +0200
Subject: [PATCH 4/5] Reorder switch cases from quietest to loudest

---
 R/deprecate.R | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/R/deprecate.R b/R/deprecate.R
index bfb72bf..fef2d95 100644
--- a/R/deprecate.R
+++ b/R/deprecate.R
@@ -107,7 +107,6 @@ deprecate_soft <- function(when,
   invisible(switch(
     verbosity,
     quiet = NULL,
-    error = deprecate_stop0(msg),
     warning = ,
     default =
       if (direct) {
@@ -121,7 +120,8 @@ deprecate_soft <- function(when,
           direct = TRUE,
           user_env = user_env
         )
-      }
+      },
+    error = deprecate_stop0(msg)
   ))
 }
 
@@ -147,7 +147,6 @@ deprecate_warn <- function(when,
   invisible(switch(
     verbosity,
     quiet = NULL,
-    error = deprecate_stop0(msg),
     warning = ,
     default = {
       direct <- is_direct(user_env)
@@ -161,7 +160,8 @@ deprecate_warn <- function(when,
         direct = direct,
         user_env = user_env
       )
-    }
+    },
+    error = deprecate_stop0(msg),
   ))
 }
 

From 345aebdeb98c72a46e40c38ec80cc879f28fb118 Mon Sep 17 00:00:00 2001
From: Lionel Henry <lionel.hry@gmail.com>
Date: Thu, 22 Sep 2022 18:36:31 +0200
Subject: [PATCH 5/5] Mention indirect behaviour in `always` doc

---
 R/deprecate.R         | 8 +++++---
 man/deprecate_soft.Rd | 8 +++++---
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/R/deprecate.R b/R/deprecate.R
index fef2d95..1f71430 100644
--- a/R/deprecate.R
+++ b/R/deprecate.R
@@ -126,9 +126,11 @@ deprecate_soft <- function(when,
 }
 
 #' @rdname deprecate_soft
-#' @param always If `FALSE`, the default, will warn every 8 hours.
-#'   If `TRUE`, will always warn. Only use `always = TRUE` after at least
-#'   one release with the default.
+#' @param always If `FALSE`, the default, will warn every 8 hours.  If
+#'   `TRUE`, will always warn in direct usages. Indirect usages keep
+#'   warning every 8 hours to avoid disrupting users who can't fix the
+#'   issue. Only use `always = TRUE` after at least one release with
+#'   the default.
 #' @export
 deprecate_warn <- function(when,
                            what,
diff --git a/man/deprecate_soft.Rd b/man/deprecate_soft.Rd
index 3e6f833..728e1cb 100644
--- a/man/deprecate_soft.Rd
+++ b/man/deprecate_soft.Rd
@@ -67,9 +67,11 @@ These are only needed if you're calling \verb{deprecate_*()} from an internal
 helper, in which case you should forward \code{env = caller_env()} and
 \code{user_env = caller_env(2)}.}
 
-\item{always}{If \code{FALSE}, the default, will warn every 8 hours.
-If \code{TRUE}, will always warn. Only use \code{always = TRUE} after at least
-one release with the default.}
+\item{always}{If \code{FALSE}, the default, will warn every 8 hours.  If
+\code{TRUE}, will always warn in direct usages. Indirect usages keep
+warning every 8 hours to avoid disrupting users who can't fix the
+issue. Only use \code{always = TRUE} after at least one release with
+the default.}
 }
 \value{
 \code{NULL}, invisibly.