Make drop error only when necessary

As suggested by @gmbecker

Author: hadley

NAMESPACE

@@ -8,6 +8,7 @@ export(strict_apply)
 export(strict_arg)
 export(strict_deactivate)
 export(strict_diag)
+export(strict_drop)
 export(strict_sample)
 export(strict_sapply)
 import(rlang)

R/shim-risky.R

@@ -10,31 +10,56 @@ strict_arg <- function(name) {
   strict_abort("Please supply a value for `", name, "` argument.", help = "strict_arg")
 }
 
-register_risky_shims <- function(env) {
+#' @export
+#' @rdname strict_arg
+#' @param j Columns to select
+strict_drop <- function(j) {
+  if (missing(j)) {
+    return(FALSE)
+  }
+
+  if ((is.numeric(j) || is.character(j)) && length(j) > 1) {
+    return(FALSE)
+  }
+
+  if (is.logical(j) && sum(j) > 1) {
+    return(FALSE)
+  }
+
+  strict_abort(
+    "Please explicitly specify `drop` when selecting a single column",
+    help = "strict_drop"
+  )
+}
+
+register_shims_risky <- function(env) {
   env_bind(env,
-    `[.data.frame` = force_strict(`[.data.frame`, "drop"),
-    as.data.frame.character = force_strict(as.data.frame.character, "stringsAsFactors"),
-    as.data.frame.list = force_strict(as.data.frame.list, "stringsAsFactors"),
-    data.frame = force_strict(data.frame, "stringsAsFactors"),
-    read.table = force_strict(utils::read.table, "stringsAsFactors"),
-    read.csv = strict_read.csv
+    as.data.frame.character = replace_strings_as_factors(as.data.frame.character),
+    as.data.frame.list =      replace_strings_as_factors(as.data.frame.list),
+    data.frame =              replace_strings_as_factors(data.frame),
+    read.table =              replace_strings_as_factors(utils::read.table),
+    `[.data.frame` =          replace_args(`[.data.frame`, drop = quote(strict_drop(j))),
+    read.csv =                strict_read_csv,
   )
 }
 
-force_strict <- function(fun, args) {
+replace_strings_as_factors <- function(fun) {
+  replace_args(fun, stringsAsFactors = quote(strict_arg("stringsAsFactors")))
+}
+
+replace_args <- function(fun, ...) {
   formals <- as.list(fn_fmls(fun))
+  args <- list(...)
 
-  for (arg in args) {
-    if (has_name(arg, formals) && !is_syntactic_literal(formals[[arg]])) {
-      formals[[arg]] <- expr(strict_arg(!!arg))
-    }
+  for (arg in names(args)) {
+    formals[[arg]] <- args[[arg]]
   }
 
   formals(fun) <- formals
   fun
 }
 
-strict_read.csv <- function(file, header = TRUE, sep = ",", quote = "\"",
+strict_read_csv <- function(file, header = TRUE, sep = ",", quote = "\"",
                             dec = ".", fill = TRUE, comment.char = "",
                             stringsAsFactors = strict_arg("stringsAsFactors"),
                             ...) {
@@ -50,8 +75,6 @@ strict_read.csv <- function(file, header = TRUE, sep = ",", quote = "\"",
     stringsAsFactors = stringsAsFactors
   )
 }
-
-
 # Helpers to find risky functions -----------------------------------------
 
 #' @examples

R/shim-scalar.R

@@ -1,4 +1,4 @@
-register_shim_scalar <- function(env) {
+register_shims_scalar <- function(env) {
   env_bind(env,
     sample = strict_sample,
     diag = strict_diag

R/shims.R

@@ -12,8 +12,8 @@ register_shims <- function() {
 
   register_shim_T_F(strict_shims)
   register_shims_apply(strict_shims)
-  register_shim_scalar(strict_shims)
-  register_risky_shims(strict_shims)
+  register_shims_risky(strict_shims)
+  register_shims_scalar(strict_shims)
 }
 
 register_shim_T_F <- function(env) {

README.Rmd

@@ -10,6 +10,7 @@ knitr::opts_chunk$set(
   comment = "#>",
   fig.path = "README-"
 )
+set.seed(1014)
 ```
 
 # strict
@@ -64,7 +65,7 @@ devtools::install_github("hadley/strict")
     ```{r}
     library(strict)
     
-    df <- data.frame(xyz = 1, stringsAsFactors = FALSE)
+    df <- data.frame(xyz = 1)
     df$x
     ```
 

README.md

@@ -49,8 +49,8 @@ Features
     library(strict)
     mtcars[, 1]
     #> Error: [strict]
-    #> Please supply a value for `drop` argument.
-    #> Please see ?strict_arg for more details
+    #> Please explicitly specify `drop` when selecting a single column
+    #> Please see ?strict_drop for more details
 
     data.frame(x = "a")
     #> Error: [strict]
@@ -63,7 +63,7 @@ Features
     ``` r
     library(strict)
 
-    df <- data.frame(xyz = 1, stringsAsFactors = FALSE)
+    df <- data.frame(xyz = 1)
     df$x
     #> Warning in `$.data.frame`(df, x): Partial match of 'x' to 'xyz' in data
     #> frame
@@ -108,11 +108,11 @@ Features
     library(strict)
 
     sample(5:3)
-    #> [1] 4 3 5
+    #> [1] 5 4 3
     sample(5:4)
     #> [1] 5 4
     lax(sample(5:5))
-    #> [1] 5 2 1 4 3
+    #> [1] 3 2 1 4 5
 
     sample(5:5)
     #> Error: [strict]

man/strict_arg.Rd

@@ -0,0 +1,14 @@
+context("shim_risky")
+
+test_that("strict_drop detects when default ok", {
+  expect_equal(strict_drop(c(TRUE, TRUE)), FALSE)
+  expect_equal(strict_drop(1:5), FALSE)
+  expect_equal(strict_drop(letters[1:2]), FALSE)
+  expect_equal(strict_drop(), FALSE)
+})
+
+test_that("strict_drop errors instead of returning TRUE", {
+  expect_error(strict_drop(c(TRUE)), "`drop`")
+  expect_error(strict_drop(1), "`drop`")
+  expect_error(strict_drop("a"), "`drop`")
+})