check_aes_for_col_refs.R

library(testthat)
library(rlang)

withr::with_namespace("ggplot2", {
  
  # Checks that mapping refers to at least one column in data
  check_aes_column_refs <- function(mapping, data) {
    if (empty(data) || length(mapping) == 0) return()
    
    data_name <- as_label(enquo(data))
    cols_in_mapping <- unlist(lapply(mapping, quo_column_refs, data))
    
    if (length(cols_in_mapping) == 0) {
      warning("Mapping contains zero mapped columns from data", call. = FALSE)
    }
  }
  
  quo_column_refs <- function(quosure, data) {
    expr_column_refs(get_expr(quosure), data, get_env(quosure))
  }
  
  expr_column_refs <- function(x, data, env = emptyenv()) {
    if (is.name(x) && (as.character(x) %in% names(data))) {
      as.character(x)
    } else if (is_call(x, "[[") && extract_target_is_quo_data(x, data, env)) {
      # in extract calls from .data, the index is not overscoped with the data
      index_value <- try(eval_tidy(x[[3]], data = NULL, env), silent = TRUE)
      if (inherits(index_value, "try-error")) {
        character(0)
      } else {
        column_ref_from_index(index_value, data)
      }
    } else if (is_call(x, "$") && extract_target_is_quo_data(x, data, env)) {
      as.character(x[[3]])
    } else if (is_call(x, "$")) {
      expr_column_refs(x[[2]], data, env)
    } else if (is.call(x)) {
      new_names <- lapply(x, expr_column_refs, data, env)
      unlist(new_names)
    } else if (is.pairlist(x)) {
      new_names <- lapply(x, expr_column_refs, data, env)
      unlist(new_names)
    } else {
      character(0)
    }
  }
  
  column_ref_from_index <- function(index, data) {
    if (is.character(index)) {
      index[1]
    } else if (is.numeric(index)) {
      names(data)[index[1]]
    } else {
      character(0)
    }
  }
  
  extract_target_is_data <- function(x, data, env) {
    data_eval <- try(eval_tidy(x[[2]], data, env), silent = TRUE)
    identical(data_eval, data)
  }
  
  extract_target_is_quo_data <- function(x, data, env) {
    identical(x[[2]], quote(.data)) || extract_target_is_data(x, data, env)
  }
  
  test_that("Column names are correctly extracted from quosures", {
    
    returns_x <- function() "x"
    df <- data_frame(x = 1:5, y = 12, nested_df = data_frame(x = 6:10))
    returns_df <- function() df
    not_df <- data_frame(x = 1:5)
    
    # valid ways to map a column
    expect_setequal(quo_column_refs(quo(x), df), "x")
    expect_setequal(quo_column_refs(quo(x * y), df), c("x", "y"))
    expect_setequal(quo_column_refs(quo(.data$x), df), "x")
    expect_setequal(quo_column_refs(quo(.data[["x"]]), df), "x")
    expect_setequal(quo_column_refs(quo(.data[[!!quo("x")]]), df), "x")
    expect_setequal(quo_column_refs(quo(.data[[returns_x()]]), df), "x")
    expect_setequal(quo_column_refs(quo(!!sym("x")), df), "x")
    expect_setequal(quo_column_refs(quo(x * 10), df), "x")
    expect_setequal(quo_column_refs(quo(nested_df$x), df), "nested_df")
    expect_setequal(quo_column_refs(quo(nested_df[["x"]]), df), "nested_df")
    expect_setequal(quo_column_refs(quo(.data[[c("nested_df", "x")]]), df), "nested_df")
    expect_setequal(quo_column_refs(quo(.data[[c(3, 1)]]), df), "nested_df")
    expect_setequal(quo_column_refs(quo(.data[[1]]), df), "x")
    
    # spurious ways to map a column that don't currently fail
    expect_setequal(quo_column_refs(quo(df$x), df), "x")
    expect_setequal(quo_column_refs(quo(returns_df()$x), df), "x")
    expect_setequal(quo_column_refs(quo(df[["x"]]), df), "x")
    
    # no columns mapped
    expect_identical(quo_column_refs(quo(), df), character(0))
    expect_identical(quo_column_refs(quo(not_a_column), df), character(0))
    expect_identical(quo_column_refs(quo(not_a_column * also_not_a_column), df), character(0))
    
    # evaluation errors should result in zero mapped columns
    expect_identical(quo_column_refs(quo(not_a_column$x), df), character(0))
    expect_identical(quo_column_refs(quo(not_df$x), df), character(0))
    expect_identical(quo_column_refs(quo(not_a_function()), df), character(0))
  })
  
  # test_that("Warnings are issued when zero columns from data are mapped", {
  #   df <- data_frame(x = 1:3, y = 3:1)
  #   p <- ggplot(df, aes(x, y)) + geom_hline(aes(yintercept = 1.5))
  #   expect_warning(ggplot_build(p), "zero mapped columns")
  # })
})