extract.symbols <- function(expr) {
if(is.symbol(expr))
expr
else if (is.method(expr))
extract.symbols(expr[[2]])
else if (is.call(expr))
if (is.method(expr[[1]]))
unlist(lapply(expr, extract.symbols))
else
unlist(lapply(expr[-1], extract.symbols))
else
NULL
}
. <- function(x) x
long.name <- function(expr, data) {
if (all(is.symbols(as.list(expr))))
if (!is.data(other <- eval(expr[[2]], .GlobalEnv)))
stop("invalid waypoint referenced: ", deparse(expr))
else if (!(att <- as.character(expr[[3]])) %in% names(other$schema))
stop("missing attribute referenced: ", deparse(expr))
else if (!other$schema[[att]] %in% data$schema)
stop("long name ", deparse(expr), " missing from current waypoint")
else
as.symbol(names(data$schema)[[which(other$schema[[as.character(expr[[3]])]] == data$schema)[[1]]]])
else
stop("attribute reference operator used incorrectly: ", deparse(expr))
}
eval. <- function(expr, data, envir = .GlobalEnv) {
if (is.call(expr))
if (is.call.to(expr, "."))
if (length(expr) != 2)
stop("the .() construct is only allowed a single argument.")
else
eval(expr[[2]], envir)
else if (is.call.to(expr, "@")) ## Evaluating attribute reference
long.name(expr, data)
else
as.call(lapply(expr, eval., data, envir))
else
expr
}
process <- function(expression, data) {
if (is.symbol(expression))
as.symbol(data$schema[[as.character(expression)]])
else
as.call(c(expression[[1]], lapply(as.list(expression)[-1], process, data)))
}
## empty: whether to leave empty strings alone.
quotate <- function(x, wrapper = '"', empty = TRUE) {
brackets <- c("{" = "}", "(" = ")", "[" = "]", "<" = ">")
if (is.bracket(as.symbol(wrapper)))
end <- brackets[[wrapper]]
else
end <- wrapper
unlist(lapply(x, function(x) {
x <- as.character(x)
if (empty && x == "")
x
else
paste0(wrapper, x, end)
}))
}
.deparse <- function(expr) {
x <- deparse(expr, width.cutoff = 500)
if (length(x) > 1) {
warning("Deparse exceeded maximum length. Possible error.")
x[-1] <- substring(x[-1], 5)
paste(x, collapse = "")
} else {
x
}
}
switch <- function(EXPR, ...) {
if (is.symbol(EXPR))
base::switch(as.character(EXPR), ...)
else
base::switch(EXPR, ...)
}
backtick <- function(x) quotate(x, '`')
mod <- function(x) sqrt(sum(x ** 2))
as.unit <- function(x) x / mod(x)
name.exprs <- function(expressions, data) {
if (length(expressions) == 0) {
names <- expressions <- names(data$schema)[match(unique(data$schema), data$schema)]
expressions <- lapply(expressions, as.symbol)
} else {
names <- names(expressions)
}
lapply(expressions, check.exprs)
atts <- unlist(lapply(expressions, convert.exprs, data = data))
check.inputs(data, atts)
exprs <- grokit$expressions[atts]
indices <- as.logical(lapply(exprs, is.symbol))
if (is.null(names)) {
names[ indices] <- unlist(lapply(exprs[indices], as.character))
names[!indices] <- paste0("V", which(!indices))
} else {
names[ indices & names == ""] <- unlist(lapply(exprs[indices & names == ""], as.character))
names[!indices & names == ""] <- paste0("V", which(!indices & names == ""))
}
names(atts) <- names
atts
}
get.schema <- function() {
offlineMode <- Sys.getenv("mode") == "offline"
if (offlineMode) {
schema <- fromJSON(file = "~/schema.json")
schema
} else {
temp <- tempfile("schema", fileext = ".txt")
system2("grokit-cli", args = c("schema", temp, mget("grokit.jobid", envir = .GlobalEnv, ifnotfound = "")))
schema <- fromJSON(file = temp)
file.remove(temp)
schema
}
}
get.exprs <- function(...) grokit$expressions[c(...)]
add.class <- function(x, class) {
class(x) <- c(class, oldClass(x))
x
}
set.class <- function(x, class) {
class(x) <- class
x
}
as.symbols <- function(x) lapply(x, as.symbol)
## create.name is used to generate unique names, separated by type.
## Given a name and a type, it returns a modification of the name that is
## different from all previously generated names for that type by appending
## an underscore and a number.
create.name <- function(name, type) {
if (!(type %in% names(grokit$names)))
grokit$names[[type]] <- integer()
if (name %in% names(grokit$names[[type]]))
grokit$names[[type]][[name]] <- grokit$names[[type]][[name]] + 1
else
grokit$names[[type]][[name]] <- 1
alias <- paste0(name, "_", grokit$names[[type]][[name]])
alias
}
create.alias <- function(name = "alias") {
alias <- create.name(name, "waypoint")
grokit$waypoints <- c(grokit$waypoints, alias)
alias
}
## Grabs the base name from a generated name by stripping off the suffix, i.e.
## the underscore and number.
base.name <- function(name)
paste(head(strsplit(name, "_")[[1]], -1), collapse = "_")
`%nin%` <- function(x, y) !(x %in% y)
make.unique <- function(names, lookup, invisible = FALSE) {
if (invisible && length(names) > 0)
names <- paste0("_", names)
as.character(lapply(names, function(name) {
while (name %in% lookup)
name <- paste0("_", name)
lookup <<- c(lookup, name)
name
}))
}
as.exprs <- function(expr) {
if (is.call.to(expr, "c"))
as.list(expr)[-1]
else
list(expr)
}
## This function takes in a character vector of library names and
## ensures they are loaded for any queries processed.
grokit.library <- function(libraries)
grokit$libraries <- c(grokit$libraries, as.character(libraries))
get.args <- function(expr) as.list(expr)[-1]
num.args <- function(expr) {
if (is.call(expr))
## as.numeric needed because sapply returns lists with 0 args
sum(as.numeric(sapply(get.args(expr), num.args)))
else
1
}
assert <- function(condition, ...) if (!condition) stop(...)
warning.if <- function(condition, ...) if (condition) warning(...)
get.catalog <- function(relation) {
catalog <- grokit$schemas$catalog
relations <- unlist(lapply(catalog, `[[`, "name"))
if (!(relation %in% relations))
stop("unavailable relation: ", relation)
index <- which(relations == relation)
catalog[[index]]
}
get.relations <- function() sapply(grokit$schemas$catalog, `[[`, "name")
get.attributes <- function(relation) sapply(get.catalog(relation)$attributes, `[[`, "name")
is.relation <- function(relation)
relation %in% get.relations()
## This function is used to simplify the process of processing the inputs and
## outputs of the parent environment that calls it. Because it intercepts the
## parser and evaluates statements in the parent environment, its usage is quite
## risky and restrained. It should only be called by a function used to create a
## waypoint that has arguments inputs and outputs.
process.io <- function(i.def, o.def, names = T) {
if (eval.parent(quote(missing(inputs)))) {
inputs <- i.def
} else {
if (inherits(tryCatch(is.inputs(inputs)), "error")) {
inputs <- quote(inputs)
check.exprs(inputs)
inputs <- convert.exprs(inputs)
} else {
inputs <- convert.inputs(inputs)
}
}
if (missing(outputs)) {
outputs <- convert.names(inputs)
missing <- which(outputs == "")
exprs <- grokit$expressions[inputs[missing]]
if (all(is.symbols(exprs)))
outputs[missing] <- as.character(exprs)
else
stop("no name given for complex inputs:",
paste("\n\t", lapply(exprs, deparse), collapse = ""))
} else {
if (!is.null(names(inputs)))
warning("both outputs and named inputs given. outputs used.")
outputs <- convert.atts(quote(outputs))
}
}
## Given a templated object, this function returns the string library::name,
## where library and name are the relevant fields of the function. Note that a
## templated function is not the same thing as a waypoint that uses one.
get.function.name <- function(object) paste0(object$library, "::", object$name)
## This function is similar to setdiff but the names of x are kept.
subtract <- function(x, y) x[!(x %in% y)]
## This function deduced the relation name. If the input evaluates to a length
## one character vector, then that is used as the name. Otherwise, if the given
## expression is a symbol, that symbol is treated as the relation name. If not,
## an error is thrown. When calling this within another function,
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.