in R, custom return value based on specific warning

Question

I have kind of a strange case where I'm trying to look for a specific warning and return one thing if I see it and a different thing if I don't. I feel like I must be missing something, but I can't figure out how to do it, at least not without calling the originating function twice. Thanks in advance for any pointers.

The specific case is: I'm reading in files with data.table::fread() and, if I see a specific parsing warning, I want to return NULL instead of the (incorrectly) parsed data.

Below are my first three attempts, and some tests to prove the issue with them. Note that my_func3 actually passes all the tests, but requires reading in all the data twice. Obviously, in my real application, the data is much larger and hence this is definitely not ideal.

# 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
1,2
3,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
1,2
TABLE NO
3,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
1,2,3
")
  )
  expect_equal(nrow(df), 1)
  expect_equal(ncol(df), 3)
})

Any thoughts on how to accomplish this without having to read the data twice are very much appreciated.

user_3743213 · Answer

Ok, I got an answer from a colleague. It is below, using the much simpler warning_prone_function() example courtesy of @allan-cameron.

The key here is to pass our custom warning back up to the enclosing environment with <<- and then check it before we return from my_func. Then we raise any other warning we may have gotten, and continue through with invokeRestart("muffleWarning"). (The muffleWarning parts prevent it from raising the same warning again when we restart. I'm pretty sure this doesn't cause warning_prone_function() to get called again, but to be honest, the invokeRestart docs baffle me a little bit, so I may be wrong. Either way, see note below about a way to do this without invokeRestart, if necessary.

Hope this is helpful for someone. Thanks for @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))
})

NOTE: technically, the tests pass if you remove the else block and the invokeRestart section:

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

However, removing these causes the original "coercion" warning and your custom warning to both be raised. Using it as written above suppresses the "coercion" warning, which was my original intent (though not stated in the OP).

user_12500315 · Answer

Unfortunately, fread doesn't lend itself well to a reproducible example, so let's create another warning-prone function:

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

This function will easily produce 2 different warnings: one if NAs are produced in coercion from strings to numbers, and a different one if all strings are the same number.

# 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

Now let's wrap our function in a warning handler that gives a custom warning and returns NULL if there is coercion, but in other cases behaves the same as 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
}

So, testing the same inputs, we get:

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

^{Created on 2021-11-15 by the reprex package (v2.0.0)}

in R, custom return value based on specific warning

2 Answers