R/utils.R

In rquery: Relational Query Generator for Data Manipulation at Scale

check_have_cols <- function(have, requested, note) {
  if(length(have)!=length(unique(have))) {
    dups <- table(have)
    dups <- names(dups[dups>1])
    stop(paste(note,"duplicate declared columns",
               paste(dups, collapse = ", ")))
  }
  requested <- unique(requested)
  diff <- setdiff(requested, have)
  if(length(diff)>0) {
    stop(paste(note,"unknown columns",
               paste(diff, collapse = ", ")))
  }
  TRUE
}


unpack_assignments <- function(source, parsed,
                               ...,
                               have = column_names(source),
                               check_is_assignment = TRUE) {
  wrapr::stop_if_dot_args(substitute(list(...)),
                          "rquery:::unpack_assignments")
  n <- length(parsed)
  assignments <- character(n)
  if(n<=0) {
    return(assignments)
  }
  nms <- character(n)
  uses <- vector(n, mode='list')
  for(i in seq_len(n)) {
    si <- parsed[[i]]
    if(length(si$symbols_produced)>1) {
      stop("more than one symbol produced")
    }
    if(check_is_assignment) {
      if(length(si$symbols_produced)!=1) {
        stop("each assignment must be of the form name := expr or name %:=% expr")
      }
    }
    if(length(si$symbols_produced)==1) {
      nms[[i]] <- si$symbols_produced
    }
    assignments[[i]] <- si$parsed
    uses[[i]] <- si$symbols_used
  }
  names(assignments) <- nms
  if(n!=length(unique(names(assignments)))) {
    stop("generated column names must be unique")
  }
  check_have_cols(have, unlist(uses), "used")
  assignments
}

parse_se <- function(source, assignments, env,
                     ...,
                     have = column_names(source),
                     check_names = TRUE,
                     allow_empty = FALSE) {
  wrapr::stop_if_dot_args(substitute(list(...)),
                          "rquery:::parse_se")
  n <- length(assignments)
  if(n<=0) {
    if(allow_empty) {
      return(list())
    }
    stop("must generate at least 1 expression")
  }
  nms <- names(assignments)
  # R-like db-info for presentation
  db_inf <- rquery_db_info(identifier_quote_char = '',
                           string_quote_char = '"',
                           is_dbi = FALSE)
  parsed <- vector(n, mode = 'list')
  for(i in seq_len(n)) {
    ni <- nms[[i]]
    ai <- assignments[[i]]
    ei <- parse(text = ai)[[1]]
    pi <- tokenize_for_SQL(ei,
                        colnames = have,
                        env = env)
    pi$symbols_produced <- unique(c(pi$symbols_produced, ni))
    pi$parsed <- pre_sql_to_query(pi$parsed_toks,
                          db_info = db_inf)
    if((!is.null(ni)) && (nchar(as.character(ni))>0)) {
      pi$presentation <- paste(ni, ":=", pi$presentation)
    }
    have <- unique(c(have, pi$symbols_produced))
    parsed[[i]] <- pi
  }
  if(check_names) {
    for(i in seq_len(n)) {
      spi <- parsed[[i]]$symbols_produced
      if((!is.character(spi)) || (length(spi)!=1) || (nchar(spi)<=0)) {
        stop("all expressions must have left-hand sides")
      }
    }
  }
  parsed
}


parse_nse <- function(source, exprs, env,
                      ...,
                      have = column_names(source),
                      check_names = TRUE,
                      allow_empty = FALSE) {
  wrapr::stop_if_dot_args(substitute(list(...)),
                          "rquery:::parse_nse")
  force(env)
  n <- length(exprs)
  if(n<=0) {
    if(allow_empty) {
      return(list())
    }
    stop("must generate at least 1 expression")
  }
  nms <- names(exprs)
  # R-like db-info for presentation
  db_inf <- rquery_db_info(identifier_quote_char = '',
                           string_quote_char = '"',
                           is_dbi = FALSE)
  parsed <- vector(n, mode = 'list')
  for(i in seq_len(n)) {
    ni <- nms[[i]]
    if(!is.null(ni)) {
      if(is.na(ni) || (nchar(ni)<=0)) {
        ni <- NULL
      }
    }
    ei <- exprs[[i]]
    # make sure LHS of := forms are evaluated early in some cases
    # (even without .())
    if(is.null(ni) && is.call(ei) && (as.character(ei[[1]]) %in% c(":=", "%:=%"))) {
      ni = ei[[2]]
      if(is.call(ni)) {
        ni = paste(as.character(eval(ni, envir=env, enclos=env)), collapse = ' ')
      } else {
        ni = paste(as.character(ni), collapse = ' ')
      }
      ei = ei[[3]]
    }
    pi <- tokenize_for_SQL(ei,
                        colnames = have,
                        env = env)
    pi$symbols_produced <- unique(c(pi$symbols_produced, ni))
    if((!is.null(ni)) && (nchar(as.character(ni))>0)) {
      pi$presentation <- paste(ni, ":=", pi$presentation)
    }
    pi$parsed <- pre_sql_to_query(pi$parsed_toks,
                          db_info = db_inf)
    have <- unique(c(have, pi$symbols_produced))
    parsed[[i]] <- pi
  }
  if(check_names) {
    for(i in seq_len(n)) {
      spi <- parsed[[i]]$symbols_produced
      if((!is.character(spi)) || (length(spi)!=1) || (nchar(spi)<=0)) {
        stop("all expressions must have left-hand sides")
      }
    }
  }
  parsed
}


# parsed is a list of named parsed lists:
# (presentation, parsed_toks, symbols_used, symbols_produced, free_symbols, parsed)
# parsed_toks is sequence of pre_sql tokens
redo_parse_quoting <- function(parsed, db_info) {
  n <- length(parsed)
  tree_rewriter <- NULL
  if("rquery_db_info" %in% class(db_info)) {
    tree_rewriter <- db_info[["tree_rewriter"]]
  }
  for(i in seq_len(n)) {
    pi <- parsed[[i]]
    if(!is.null(tree_rewriter)) {
      pi$parsed_toks <- tree_rewriter(pi$parsed_toks, db_info)
    }
    pi$parsed <- pre_sql_to_query(pi$parsed_toks,
                          db_info = db_info)
    parsed[[i]] <- pi
  }
  parsed
}



# get field by name from list
merge_fld <- function(reslist, field) {
  if(length(reslist)<=0) {
    return(NULL)
  }
  got <- lapply(reslist,
                function(ri) {
                  ri[[field]]
                })
  unique(unlist(got))
}


# merge named maps of column vectors
# rquery:::merge_columns_used(list(x = c("a", "b"), y = "c"), list(x = c("d")))
# should match list(x = c("a", "b", "d"), y = c("c"))
merge_columns_used <- function(cu1, cu2) {
  nms <- sort(unique(c(names(cu1), names(cu2))))
  cu <- lapply(nms,
               function(ni) {
                 sort(unique(c(cu1[[ni]], cu2[[ni]])))
               })
  names(cu) <- nms
  cu
}

rquery_deparse <- function(item) {
  paste(as.character(deparse(item, width.cutoff = 500L)),
        collapse = "\n ")
}