在 R 中，基于特定警告的自定义返回值

Question

我有一种奇怪的情况，我试图寻找一个特定的警告，如果我看到它就返回一个东西，如果我没有看到它就返回一个不同的东西。我觉得我一定错过了一些东西，但我不知道该怎么做，至少在没有两次调用原始函数的情况下是这样。提前感谢您的任何指点。

具体情况是：我正在读取带有 data.table::fread() 的文件，如果我看到特定的解析警告，我想返回 NULL 而不是（错误地）解析的数据。

以下是我的前三个尝试，以及一些证明它们存在问题的测试。请注意，my_func3 实际上通过了所有测试，但需要读取所有数据两次。显然，在我的实际应用中，数据要大得多，因此这绝对是不理想的。

# this one fails test 3
# because it doesn't return anything if _any_ warning is caught
my_func1 <- function(.string) {
  res <- tryCatch(
    {
      data.table::fread(text = .string)
    },
    warning = function(.w) {
      if (grepl("Stopped early.+TABLE NO", .w$message)) {
        warning("my custom warning")
        return(NULL)
      } else {
        warning(.w)
      }
    }
  )
}

# this one fails test 2
# because it returns the parsed df even if we catch the custom warning
my_func2 <- function(.string) {
  res <- withCallingHandlers(
    {
      data.table::fread(text = .string)
    },
    warning = function(.w) {
      if (grepl("Stopped early.+TABLE NO", .w$message)) {
        warning("my custom warning")
        return(NULL)
      } else {
        warning(.w)
      }
    }
  )
}


# this one passes all three
# but it requires reading the data twice
my_func3 <- function(.string) {
  res <- tryCatch(
    {
      data.table::fread(text = .string)
    },
    warning = function(.w) {
      if (grepl("Stopped early.+TABLE NO", .w$message)) {
        warning("my custom warning")
        return(NULL)
      } else {
        data.table::fread(text = .string)
      }
    }
  )
}



##################
# TESTS
##################

# uncomment the one you want to test
#my_func <- my_func1
#my_func <- my_func2
#my_func <- my_func3

library(testthat)

test_that("test 1: my_func returns df when no warning", {
  df <- my_func("a,b\n1,2\n3,4")
  expect_equal(nrow(df), 2)
  expect_equal(ncol(df), 2)
})

test_that("test 2: my_func warns and returns NULL on custom warning", {
  expect_warning(
    df <- my_func("a,b\n1,2\nTABLE NO\n3,4"),
    regexp = "my custom warning"
  )
  expect_null(df)
})

test_that("test 3: my_func warns and returns df on other warning ", {
  expect_warning(
    df <- my_func("a,b\n1,2,3\n")
  )
  expect_equal(nrow(df), 1)
  expect_equal(ncol(df), 3)
})

非常感谢您对如何读取数据两次来完成此操作的任何想法。

Answer 1

好的，我从一位同事那里得到了答复。下面是使用@allan-cameron 提供的更简单的warning_prone_function() 示例。

这里的关键是使用<<- 将我们的自定义警告传回封闭环境，然后在我们从my_func 返回之前检查它。然后我们提出我们可能收到的任何其他警告，并继续使用invokeRestart("muffleWarning")。 （muffleWarning 部分阻止它在我们重新启动时再次发出相同的警告。我非常确定这不会导致 warning_prone_function() 再次被调用，但老实说，@ 987654327@ docs 让我有点困惑，所以我可能是错的。无论哪种方式，如果需要，请参阅下面的注释，了解如何在没有 invokeRestart 的情况下执行此操作。

希望这对某人有所帮助。感谢@allan-cameron。

warning_prone_function <- function(.string) {
  num <- as.numeric(.string)
  num <- num[!is.na(num)]
  cor(seq_along(num), num)
}


my_func <- function(.string) {
  W <- NULL
  res <- withCallingHandlers(
    {
      warning_prone_function(.string)
    },
    warning = function(.w) {
      if (grepl("coercion", .w$message)) {
        W <<- "Some strings were not numbers"
      } else {
        warning(.w)
      }
      invokeRestart("muffleWarning")
    }
  )
  
  if (!is.null(W)) {
    warning(W)
    res <- NULL
  }
  
  return(res)
}

###############
# TESTS
###############

library(testthat)

test_that("test 1: my_func returns df when no warning", {
  res <- my_func(c("1", "2", "3"))
  expect_equal(res, 1)
})

test_that("test 2: my_func warns and returns NULL on custom warning", {
  expect_warning(
    res <- my_func(c("a", "b", "c")),
    regexp = "Some strings were not numbers"
  )
  expect_null(res)
})

test_that("test 3: my_func warns and returns res on other warning ", {
  expect_warning(
    res <- my_func(c("1", "1", "1")),
    "standard deviation"
  )
  expect_true(is.na(res))
})

注意： 从技术上讲，如果您删除 else 块和 invokeRestart 部分，则测试通过：

        else {
        warning(.w)
      }
      invokeRestart("muffleWarning")

但是，删除这些会导致原始"coercion" 警告和您的自定义警告都被引发。如上所述使用它会抑制 "coercion" 警告，这是我的初衷（尽管 OP 中没有说明）。

Answer 2

不幸的是，fread 不适合作为可重现的示例，所以让我们创建另一个容易出现警告的函数：

warning_prone_function <- function(.string)
{
    num <- as.numeric(.string)
    num <- num[!is.na(num)]
    cor(seq_along(num), num)
}

这个函数很容易产生 2 个不同的警告：一个是 NA 是从字符串强制转换为数字时产生的，另一个是如果所有字符串都是相同的数字。

# Input OK - no warning
warning_prone_function(c("1", "2", "3"))
#> [1] 1

# Input produces standard deviation warning
warning_prone_function(c("1", "1", "1"))
#> Warning in cor(seq_along(num), num): the standard deviation is zero
#> [1] NA

# Input produces coercion warning
warning_prone_function(c("a", "b", "c"))
#> Warning in warning_prone_function(c("a", "b", "c")): NAs introduced by coercion
#> [1] NA

现在让我们将函数包装在一个警告处理程序中，该处理程序给出一个自定义警告，如果存在强制，则返回 NULL，但在其他情况下，其行为与 warning_prone_function 相同

my_func <- function(.string) {

  res <- tryCatch(
    {
      warning_prone_function(.string)
    },
    warning = function(.w) {
      if (grepl("coercion", .w$message)) {
        warning("Some strings were not numbers")
        return(NULL)
      } else {
        warning_prone_function(.string)
      }
    }
  )
  res
}

所以，测试相同的输入，我们得到：

my_func(c("1", "2", "3"))
#> [1] 1

my_func(c("1", "1", "1"))
#> Warning in cor(seq_along(num), num): the standard deviation is zero
#> [1] NA

my_func(c("a", "b", "c"))
#> Warning in value[[3L]](cond): Some strings were not numbers
#> NULL

^{由reprex package (v2.0.0) 于 2021 年 11 月 15 日创建}