translate-sql.R

#' Translate an expression to sql.
#'
#' @section Base translation:
#' The base translator, `base_sql`,
#' provides custom mappings for `!` (to NOT), `&&` and `&` to
#' `AND`, `||` and `|` to `OR`, `^` to `POWER`,
#' `%>%` to `%`, `ceiling` to `CEIL`, `mean` to
#' `AVG`, `var` to `VARIANCE`, `tolower` to `LOWER`,
#' `toupper` to `UPPER` and `nchar` to `LENGTH`.
#'
#' `c()` and `:` keep their usual R behaviour so you can easily create
#' vectors that are passed to sql.
#'
#' All other functions will be preserved as is. R's infix functions
#' (e.g. `%like%`) will be converted to their SQL equivalents
#' (e.g. `LIKE`). You can use this to access SQL string concatenation:
#' `||` is mapped to `OR`, but `%||%` is mapped to `||`.
#' To suppress this behaviour, and force errors immediately when dplyr doesn't
#' know how to translate a function it encounters, using set the
#' `dplyr.strict_sql` option to `TRUE`.
#'
#' You can also use [sql()] to insert a raw sql string.
#'
#' @section SQLite translation:
#' The SQLite variant currently only adds one additional function: a mapping
#' from `sd()` to the SQL aggregation function `STDEV`.
#'
#' @param ...,dots Expressions to translate. `translate_sql()`
#'   automatically quotes them for you.  `translate_sql_()` expects
#'   a list of already quoted objects.
#' @param con An optional database connection to control the details of
#'   the translation. The default, `NULL`, generates ANSI SQL.
#' @param vars Deprecated. Now call [partial_eval()] directly.
#' @param vars_group,vars_order,vars_frame Parameters used in the `OVER`
#'   expression of windowed functions.
#' @param window Use `FALSE` to suppress generation of the `OVER`
#'   statement used for window functions. This is necessary when generating
#'   SQL for a grouped summary.
#' @param context Use to carry information for special translation cases. For example, MS SQL needs a different conversion for is.na() in WHERE vs. SELECT clauses.  Expects a list.
#' @export
#' @examples
#' # Regular maths is translated in a very straightforward way
#' translate_sql(x + 1)
#' translate_sql(sin(x) + tan(y))
#'
#' # Note that all variable names are escaped
#' translate_sql(like == "x")
#' # In ANSI SQL: "" quotes variable _names_, '' quotes strings
#'
#' # Logical operators are converted to their sql equivalents
#' translate_sql(x < 5 & !(y >= 5))
#' # xor() doesn't have a direct SQL equivalent
#' translate_sql(xor(x, y))
#'
#' # If is translated into case when
#' translate_sql(if (x > 5) "big" else "small")
#'
#' # Infix functions are passed onto SQL with % removed
#' translate_sql(first %like% "Had%")
#' translate_sql(first %is% NA)
#' translate_sql(first %in% c("John", "Roger", "Robert"))
#'
#' # And be careful if you really want integers
#' translate_sql(x == 1)
#' translate_sql(x == 1L)
#'
#' # If you have an already quoted object, use translate_sql_:
#' x <- quote(y + 1 / sin(t))
#' translate_sql_(list(x), con = simulate_dbi())
#'
#' # Windowed translation --------------------------------------------
#' # Known window functions automatically get OVER()
#' translate_sql(mpg > mean(mpg))
#'
#' # Suppress this with window = FALSE
#' translate_sql(mpg > mean(mpg), window = FALSE)
#'
#' # vars_group controls partition:
#' translate_sql(mpg > mean(mpg), vars_group = "cyl")
#'
#' # and vars_order controls ordering for those functions that need it
#' translate_sql(cumsum(mpg))
#' translate_sql(cumsum(mpg), vars_order = "mpg")
translate_sql <- function(...,
                          con = simulate_dbi(),
                          vars = character(),
                          vars_group = NULL,
                          vars_order = NULL,
                          vars_frame = NULL,
                          window = TRUE) {

  if (!missing(vars)) {
    abort("`vars` is deprecated. Please use partial_eval() directly.")
  }

  translate_sql_(
    quos(...),
    con = con,
    vars_group = vars_group,
    vars_order = vars_order,
    vars_frame = vars_frame,
    window = window
  )
}

#' @export
#' @rdname translate_sql
translate_sql_ <- function(dots,
                           con = NULL,
                           vars_group = NULL,
                           vars_order = NULL,
                           vars_frame = NULL,
                           window = TRUE,
                           context = list()) {

  if (length(dots) == 0) {
    return(sql())
  }

  stopifnot(is.list(dots))

  if (!any(have_name(dots))) {
    names(dots) <- NULL
  }

  old_con <- set_current_con(con)
  on.exit(set_current_con(old_con), add = TRUE)

  if (length(context) > 0) {
    old_context <- set_current_context(context)
    on.exit(set_current_context(old_context), add = TRUE)
  }

  if (window) {
    old_group <- set_win_current_group(vars_group)
    on.exit(set_win_current_group(old_group), add = TRUE)

    old_order <- set_win_current_order(vars_order)
    on.exit(set_win_current_order(old_order), add = TRUE)

    old_frame <- set_win_current_frame(vars_frame)
    on.exit(set_win_current_frame(old_frame), add = TRUE)
  }

  variant <- sql_translate_env(con)
  pieces <- lapply(dots, function(x) {
    if (is_null(get_expr(x))) {
      NULL
    } else if (is_atomic(get_expr(x))) {
      escape(get_expr(x), con = con)
    } else {
      mask <- sql_data_mask(x, variant, con = con, window = window)
      escape(eval_tidy(x, mask), con = con)
    }
  })

  sql(unlist(pieces))
}

sql_data_mask <- function(expr, variant, con, window = FALSE,
                          strict = getOption("dplyr.strict_sql", FALSE)) {
  stopifnot(is.sql_variant(variant))

  # Default for unknown functions
  if (!strict) {
    unknown <- setdiff(all_calls(expr), names(variant))
    top_env <- ceply(unknown, default_op, parent = empty_env())
  } else {
    top_env <- child_env(NULL)
  }


  # Known R -> SQL functions
  special_calls <- copy_env(variant$scalar, parent = top_env)
  if (!window) {
    special_calls2 <- copy_env(variant$aggregate, parent = special_calls)
  } else {
    special_calls2 <- copy_env(variant$window, parent = special_calls)
  }

  # Existing symbols in expression
  names <- all_names(expr)
  idents <- lapply(names, ident)
  name_env <- ceply(idents, escape, con = con, parent = special_calls2)

  # Known sql expressions
  symbol_env <- env_clone(base_symbols, parent = name_env)

  new_data_mask(symbol_env, top_env)
}

is_infix_base <- function(x) {
  x %in% c("::", "$", "@", "^", "*", "/", "+", "-", ">", ">=", "<", "<=",
    "==", "!=", "!", "&", "&&", "|", "||", "~", "<-", "<<-")
}
is_infix_user <- function(x) {
  grepl("^%.*%$", x)
}

default_op <- function(x) {
  assert_that(is_string(x))

  if (is_infix_base(x)) {
    sql_infix(x)
  } else if (is_infix_user(x)) {
    x <- substr(x, 2, nchar(x) - 1)
    sql_infix(x)
  } else {
    sql_prefix(x)
  }
}


all_calls <- function(x) {
  if (is_quosure(x)) return(all_calls(quo_get_expr(x)))
  if (!is.call(x)) return(NULL)

  fname <- as.character(x[[1]])
  unique(c(fname, unlist(lapply(x[-1], all_calls), use.names = FALSE)))
}

all_names <- function(x) {
  if (is.name(x)) return(as.character(x))
  if (is_quosure(x)) return(all_names(quo_get_expr(x)))
  if (!is.call(x)) return(NULL)

  unique(unlist(lapply(x[-1], all_names), use.names = FALSE))
}

# character vector -> environment
ceply <- function(x, f, ..., parent = parent.frame()) {
  if (length(x) == 0) return(new.env(parent = parent))
  l <- lapply(x, f, ...)
  names(l) <- x
  list2env(l, parent = parent)
}