### =========================================================================
### SolrQuery objects
### -------------------------------------------------------------------------
### Represents a query to a Solr search engine.
### A SolrQuery is evaluated by a SolrCore to yield a SolrResult. All
### operations are deferred until evaluation, i.e., when eval() is
### called. Since the lazy behavior is explicit, it is paramount that
### we do not evaluate any query expressions until the query is
### evaluated. An easy way to achieve that is to simply store the R
### language objects, along with their enclosing context, which
### includes the calling R environment, as well as the expressions
### defining virtual columns via transform(). Those column expressions
### are actively bound to the environment, and the active binding
### evaluates the expression inside the environment (and saves the
### result, making the binding static). The expression of interest is
### evaluated in the environment. Finally, we extract the expression
### from each promise, coerce it to character, and collapse the
### results to the URL query string.
setClass("SolrQuery",
representation(params="list"),
prototype = list(
params = list(
q = "*:*",
start = 0L,
rows = .Machine$integer.max,
fl = list("*"))
))
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Constructor
###
SolrQuery <- function(expr, requestHandler = NULL, ...)
{
ans <- new("SolrQuery")
if (!missing(expr)) {
ans <- eval(substitute(subset(ans, expr)), parent.frame())
}
requestHandler(ans) <- requestHandler
args <- list(...)
params(ans)[names(args)] <- args
ans
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Low-level accessors
###
params <- function(x) {
x@params
}
`params<-` <- function(x, value) {
x@params <- value
x
}
configure <- function(x, ...) {
args <- c(...)
x@params[names(args)] <- args
x
}
json <- function(x) {
params(x)[["json"]]
}
`json<-` <- function(x, value) {
params(x)[["json"]] <- value
x
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### SolrQueryTranslationSource
###
### The intent is to preserve the state when the translation was requested
###
setClassUnion("formulaORNULL", c("formula", "NULL"))
### DOCDB: DocDbQueryTranslationSource does not track a grouping. That
### state should be on SolrQuery, and the DocDbFrame method should
### yield a GroupedSolrFrame if necessary.
QueryHandle <- setRefClass("QueryHandle",
fields=c(i="character"),
methods=list(
get = function() QUERY_HEAP$get(.self),
finalize = function() QUERY_HEAP$remove(.self)
))
setMethod("show", "QueryHandle",
function(object) cat("QueryHandle:", as.character(object), "\n"))
as.character.QueryHandle <- function(x) x$i
QueryHeap_store <- function(query) {
key <- .self$nextKey()
.self$queries[[as.character(key)]] <- query
key
}
QueryHeap_nextKey <- function() {
if (length(.self$free) > 0L) {
i <- .self$free[1L]
.self$free <- .self$free[-1L]
} else {
i <- as.character(length(.self))
}
QueryHandle(i=i)
}
globalVariables(".self")
QueryHeap_get <- function(key) {
.self$queries[[as.character(key)]]
}
QueryHeap_remove <- function(key) {
i <- as.character(key)
if (length(i) == 1L) { # be robust to dummy handle finalization
rm(list=i, envir=.self$queries)
.self$free <- c(.self$free, i)
}
invisible(.self)
}
QUERY_HEAP <- setRefClass("QueryHeap",
fields=c(queries="environment",
free="character"),
methods = list(add=QueryHeap_store,
nextKey=QueryHeap_nextKey,
get=QueryHeap_get,
remove=QueryHeap_remove))()
length.QueryHeap <- function(x) length(x$queries)
setMethod("show", "QueryHeap",
function(object) cat("QueryHeap with", length(object), "queries\n"))
setClass("SolrQueryTranslationSource",
representation(expr="ANY",
queryHandle="QueryHandle",
env="environment",
grouping="formulaORNULL"),
contains="Expression")
setMethod("translate", c("SolrQueryTranslationSource", "Expression"),
function(x, target, core, ...) {
query <- x@queryHandle$get()
frame <- group(.SolrFrame(core, query), x@grouping)
context <- DelegateContext(frame, x@env)
translate(expr(x), target, context, ...)
})
setMethod("as.character", "SolrQueryTranslationSource",
function(x) {
if (is.language(expr(x))) {
deparse(expr(x))
} else {
as.character(expr(x))
}
})
deferTranslation <- function(x, expr, target, env, grouping=NULL) {
expr <- preprocessExpression(expr, env)
queryHandle <- QUERY_HEAP$add(x)
fenv <- funsEnv(expr, env)
src <- new("SolrQueryTranslationSource", expr=expr, queryHandle=queryHandle,
env=fenv, grouping=grouping)
new("TranslationRequest", src=src, target=target)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Solr query component
###
setMethod("translate", c("SolrQueryTranslationSource", "SolrQParserExpression"),
function(x, target, ...) {
expr <- callNextMethod()
initialize(expr, tag=tag(target))
})
setMethod("tag", "TranslationRequest", function(x) tag(x@target))
setMethod("subset", "SolrQuery",
function(x, subset, select, fields, select.from = character()) {
if (!missing(subset)) {
tag <- sum(names(params(x)) == "fq")
fq <- deferTranslation(x, substitute(subset),
SolrQParserExpression(tag),
top_prenv(subset))
params(x) <- c(params(x), fq = fq)
}
if (!missing(select)) {
if (!missing(fields)) {
stop("only one of 'fields' and 'select' can be specified")
}
inds <- as.list(seq_along(select.from))
names(inds) <- select.from
fields <- select.from[eval(substitute(select), inds, top_prenv(select))]
}
if (!missing(fields)) {
x <- restrictToFields(x, fields)
}
x
})
setGeneric("searchDocs", function(x, q, ...) standardGeneric("searchDocs"))
setMethod("searchDocs", c("SolrQuery", "ANY"), function(x, q) {
q <- as.character(q)
stopifnot(isSingleString(q))
params(x)$q <- q
sort(x, by=~score, decreasing=TRUE)
})
isSimpleFilter <- function(x) {
if (is.null(x@params$fq))
return(FALSE)
x@params$fq <- NULL
identical(x, SolrQuery())
}
predicateExpression <- function(x, core) {
if (isSimpleFilter(x)) translate(x@params$fq, core=core)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Output manipulation
###
transform.SolrQuery <- function(`_data`, ...) transform(`_data`, ...)
setMethod("transform", "SolrQuery", function (`_data`, ...) {
e <- as.list(substitute(list(...))[-1L])
if (length(e) == 0L)
return(`_data`)
if (is.null(names(e)))
names(e) <- ""
fl <- mapply(deferTranslation, list(`_data`), e,
list(SolrFunctionExpression()),
top_prenv_dots(...))
## If a simple symbol is passed, Solr will rename the field, rather
## than copy the column. That is different from transform()
## behavior. Sure, aliasing is sort of pointless server-side, but
## we do not want to surprise the user.
aliased <- vapply(e, is.name, logical(1L))
identity.aliases <- unique(as.character(e[aliased]))
params(`_data`)$fl <- c(params(`_data`)$fl, setNames(fl, names(e)),
setNames(identity.aliases, identity.aliases))
`_data`
})
### Also exists in S4Vectors, but the mapping is opposite!
setGeneric("rename", function(x, ...) standardGeneric("rename"))
setMethod("rename", "SolrQuery", function(x, ...) {
map <- c(...)
if (!is.character(map) || any(is.na(map))) {
stop("arguments in '...' must be character and not NA")
}
fl <- lapply(map, as, "SolrFunctionExpression")
params(x)$fl <- c(params(x)$fl, fl)
x
})
solrInf <- SolrFunctionCall("div", list(1, 0))
solrNegInf <- SolrFunctionCall("div", list(-1, 0))
### SOLRBUG:
### Seems that character types do not sort via function queries.
### Any NAs are probably treated as empty strings and therefore come first,
### unless the schema is configured to sort NAs specially.
isCharacterSymbol <- function(expr, core) {
if (is(expr, "SolrSymbol")) {
name(expr) != "score" &&
!is(fieldTypes(schema(core), name(expr))[[1L]], "CharacterField")
} else {
FALSE
}
}
### FIXME: we substitute (-)infinity for NAs so that they sort
### last. Solr itself supports sorting NAs last or first, according to
### a setting in the schema. If we tracked that information, we could
### avoid this hack in the case of symbols. But it's debatable whether
### we should always obey the schema, or try to be always consistent
### with R (and calls, which we would need to treat ourselves).
setMethod("translate", c("SolrQueryTranslationSource", "SolrSortExpression"),
function(x, target, core, ...) {
by <- translate(x, target@by, core, ...)
if (!isCharacterSymbol(by, core)) {
inf <- if (target@decreasing) solrNegInf else solrInf
by <- propagateNAs(by, inf)
}
initialize(target, by=by)
})
sortParams <- function(x, by, decreasing) {
lapply(stripI(parseFormulaRHS(by)), deferTranslation, x=x,
target=SolrSortExpression(decreasing), env=attr(by, ".Environment"))
}
setMethod("sort", "SolrQuery", function (x, decreasing = FALSE, by = ~ score) {
if (!isTRUEorFALSE(decreasing))
stop("'decreasing must be TRUE or FALSE")
sort <- sortParams(x, by, decreasing)
params(x)$sort <- c(sort, params(x)$sort)
x
})
rev.SolrQuery <- function (x, ...) rev(x)
setMethod("rev", "SolrQuery", function(x) {
if (is.null(params(x)$sort))
x <- sort(x)
else {
params(x)$sort <- lapply(params(x)$sort, function(xi) {
xi@target@decreasing <-
!xi@target@decreasing
xi
})
}
x
})
### head/tail are complicated, because the indices can be relative to the
### end, which we do not know, because NROWS is not known. We indicate
### this using negative values.
## head(x, -n) => (-)rows = min(rows, NROWS)-n
## head(x, +n) => (+)rows = min(rows, n)
## tail(x, +n) => (-)start = start+min(rows, NROWS)-n; rows = min(rows, n)
## tail(x, -n) => (+)start = start+n; rows = min(rows, NROWS)-n
window.SolrQuery <- function(x, ...) window(x, ...)
setMethod("window", "SolrQuery", function (x, start = 1L, end = NA_integer_) {
if (!isSingleNumber(start))
stop("'start' must be a single, non-NA number")
if (!is.na(end) && !isSingleNumber(end))
stop("'end' must be a single number")
rows <- end - start + 1L
setOutputBounds(x, start, rows)
})
setOutputBounds <- function(x, start = 1L, rows = NA_integer_) {
start <- start - 1L
params(x) <- boundsParams(params(x), start, rows)
x
}
boundsParams <- function(p, start, rows) {
if (identical(rows, 0L)) { # simplify for trivial case of no results
p$start <- p$rows <- NULL
}
p$start <- c(p$start, start)
p$rows <- c(p$rows, rows)
p
}
head.SolrQuery <- function (x, n = 6L, ...) {
if (!isSingleNumber(n))
stop("'n' must be a single, non-NA number")
setOutputBounds(x, rows = n)
}
setMethod("head", "SolrQuery", head.SolrQuery)
tail.SolrQuery <- function (x, n = 6L, ...) {
if (!isSingleNumber(n))
stop("'n' must be a single, non-NA number")
setOutputBounds(x, start = -n + 1L)
}
setMethod("tail", "SolrQuery", tail.SolrQuery)
outputRestricted <- function(x) {
params(x)$start > 0L || params(x)$rows < .Machine$integer.max
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Group component
###
### Only useful because it truncates by group.
###
configureGroups <- function(x, limit, offset, ...) {
if (!isSingleNumber(limit)) {
stop("'limit' must be a single, non-NA number")
}
if (!isSingleNumber(offset)) {
stop("'offset' must be a single, non-NA number")
}
if (is.null(params(x)$group.sort)) {
params(x)$group.sort <- params(x)$sort
params(x)$sort <- NULL
}
configure(x, group="true", group.limit=limit, group.offset=offset, ...)
}
setGeneric("group", function(x, by, ...) standardGeneric("group"))
setMethod("group", c("SolrQuery", "language"),
function(x, by, limit = .Machine$integer.max, offset = 0L,
env = emptyenv()) {
func <- deferTranslation(x, by, SolrFunctionExpression(), env)
configureGroups(x, limit, offset, group.func=func)
})
setMethod("group", c("SolrQuery", "name"),
function(x, by, limit = .Machine$integer.max, offset = 0L, env) {
group(x, by=as.character(by), limit=limit, offset=offset)
})
setMethod("group", c("SolrQuery", "character"),
function(x, by, limit = .Machine$integer.max, offset = 0L) {
if (!isSingleString(by)) {
stop("'by' must be a single, non-NA string")
}
configureGroups(x, limit, offset, group.field=by)
})
setMethod("group", c("SolrQuery", "formula"), function(x, by, ...) {
hasLHS <- length(by) == 3L
if (hasLHS) {
x <- subset(x, fields=as.character(by[[2L]]))
by[[2L]] <- NULL
}
exprs <- parseFormulaRHS(by)
if (length(exprs) > 1L) {
stop("'by' must be a formula with a single term")
}
sort(group(x, exprs[[1L]], env=attr(by, ".Environment"), ...), by=by)
})
grouped <- function(x) identical(params(x)$group, "true")
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Facet component
###
### NOTE: We only support 'exclude' for compatibility with
### xtabs(na.action=na.pass, exclude=NULL), but with our default,
### only 'na.action=na.pass' is needed for counting NAs.
normNAAction <- function(na.action) {
if (missing(na.action)) {
na.action <- getOption("na.action", na.omit)
}
na.action <- match.fun(na.action)
if (!identical(na.action, na.omit) &&
!identical(na.action, na.pass)) {
stop("'na.action' must be either 'na.omit' or 'na.pass'")
}
na.action
}
setMethod("xtabs", "SolrQuery",
function(formula, data,
subset, sparse = FALSE,
na.action, addNA = FALSE, exclude = if (!addNA) NA,
drop.unused.levels = FALSE) {
if (!identical(sparse, FALSE)) {
stop("'sparse' must be FALSE")
}
na.action <- normNAAction(na.action)
if (!isTRUEorFALSE(addNA)) {
stop("'addNA' must be TRUE or FALSE")
}
if (!is.null(exclude) &&
!(length(exclude)==1L && is.na(exclude))) {
stop("'exclude' should be 'NA' or 'NULL'")
}
useNA <- addNA ||
is.null(exclude) && identical(na.action, na.pass)
if (!missing(subset)) {
data <- rsolr::subset(data, .(substitute(subset)))
}
facet(data, formula, useNA=useNA, drop=drop.unused.levels)
})
setGeneric("facet", function(x, by = NULL, ...) standardGeneric("facet"))
setMethod("facet", c("SolrQuery", "NULL"),
function(x, by, ..., useNA=FALSE, sort=NULL,
decreasing=FALSE, limit=NA_integer_) {
stats <- statsParams(x, by, ...)
facetParams(x)[names(stats)] <- stats
x
})
setMethod("facet", c("SolrQuery", "formula"), function(x, by, ...) {
factors <- parseFormulaRHS(by)
facetParams(x) <- mergeFacetParams(x, json(x)$facet, factors,
grouping=by,
where=attr(by, ".Environment"),
...)
x
})
setMethod("facet", c("SolrQuery", "character"), function(x, by, ...) {
facetParams(x)[by] <- facetParams(x, by, ...)
x
})
setGeneric("facetParams", function(x, by=list(), ...)
standardGeneric("facetParams"))
setMethod("facetParams", c("SolrQuery", "missing"), function(x, by, ...) {
json(x)$facet
})
setMethod("facetParams", c("SolrQuery", "character"),
function(x, by, ..., useNA=FALSE, sort=NULL,
decreasing=FALSE, limit=NA_integer_, drop=TRUE) {
if (!isTRUEorFALSE(useNA)) {
stop("'useNA' must be TRUE or FALSE")
}
if (any(is.na(by))) {
stop("'by' must not contain NAs")
}
groupings <- lapply(by, function(f) as.formula(paste("~", f)))
aliased <- by %in% names(params(x)$fl)
facetAlias <- function(fl, grouping) {
facetParams(x, fl, ..., grouping=grouping, useNA=useNA,
sort=sort, decreasing=decreasing, limit=limit,
drop=drop)
}
params <- mapply(facetAlias, params(x)$fl[by[aliased]],
groupings[aliased], SIMPLIFY=FALSE)
sort <- facetSort(x, sort, decreasing)
limit <- facetLimit(limit)
mincount <- facetMinCount(drop, ...)
params[by[!aliased]] <-
mapply(function(f, grouping) {
stats <- statsParams(x, grouping, ...)
list(type="terms", field=f,
missing=useNA,
facets=stats, sort=sort,
limit=limit, mincount=mincount)
}, by[!aliased], groupings[!aliased],
SIMPLIFY=FALSE)
params
})
setMethod("facetParams", c("SolrQuery", "Symbol"),
function(x, by, where, grouping, ...) {
facetParams(x, as.character(by), ...)[[1L]]
})
setMethod("facetParams", c("SolrQuery", "call"),
function(x, by, where, grouping, ..., useNA=FALSE, sort=NULL,
decreasing=FALSE, limit=NA_integer_, drop=TRUE) {
### FIXME: Support useNA=TRUE for query facets without extra stats,
### since we have the overall count in the parent bucket.
if (!identical(useNA, FALSE)) {
stop("'useNA' must be FALSE for complex facets")
}
if (!is.null(sort)) {
stop("'sort' is not supported for complex facets")
}
if (!identical(limit, NA_integer_)) {
stop("'limit' is not supported for complex facets")
}
if (by[[1L]] == quote(cut)) {
by[[1L]] <- facet_cut
params <- eval(by, where)
} else {
query <- deferTranslation(x, by, SolrQParserExpression(),
where)
params <- list(type="query", q=query)
}
## NOTE: Solr ignores mincount on query facet, but we handle later
c(params, list(facet=statsParams(x, grouping, ...),
mincount=facetMinCount(drop, ...)))
})
setMethod("facetParams", c("SolrQuery", "TranslationRequest"),
function(x, by, ...) {
facetParams(x, by@src@expr, where=by@src@env, ...)
})
`facetParams<-` <- function(x, value) {
if (outputRestricted(x)) {
warning("facets will ignore head/tail restriction")
}
json(x)$facet <- structure(value, class="facetlist")
x
}
facetLimit <- function(x) {
if (!isSingleNumberOrNA(x)) {
stop("facet limit must be a single number, or NA")
}
if (is.na(x)) {
x <- -1L
}
x
}
### FIXME: Sorting facet buckets does not handle NAs very well, since
### Solr is doing the sorting, and it does not treat NAs
### reasonably. Sure, we could sort ourselves, but really the whole
### point of sorting is so that we can tell Solr to truncate the output.
facetSort <- function(x, sort, decreasing) {
if (!isTRUEorFALSE(decreasing)) {
stop("'decreasing' must be TRUE or FALSE")
}
dir <- if (decreasing) "desc" else "asc"
if (is(sort, "formula")) {
f <- parseFormulaRHS(sort)
paste(vapply(f, function(t) {
if (is.name(t)) {
paste(t, dir)
} else {
stop("facet sort term must name a statistic")
}
}, character(1L)),
collapse=",")
} else if (is.null(sort)) {
paste("index", dir)
} else {
stop("invalid facet sort specification")
}
}
facetMinCount <- function(drop, ...) {
if (!isTRUEorFALSE(drop)) {
stop("'drop' must be TRUE or FALSE")
}
if (!drop && !missing(...)) {
stop("'drop' must be TRUE when statistics are requested")
}
if (drop) 1L else 0L
}
setGeneric("makeName", function(x) standardGeneric("makeName"))
setMethod("makeName", "TranslationRequest", function(x) {
makeName(x@src@expr)
})
setMethod("makeName", "name", function(x) {
x
})
setMethod("makeName", "call", function(x) {
paste0(makeName(x[[2L]]), ".", x[[1L]])
})
setMethod("makeName", "Promise", function(x) {
makeName(expr(x))
})
setMethod("makeName", "SolrAggregateCall", function(x) {
paste0(makeName(x@subject), ".", x@name)
})
setMethod("makeName", "SolrFunctionCall", function(x) {
if (length(x@args) > 1L) {
x@args <- x@args[-1L]
suffix <- x
} else {
suffix <- x@name
}
paste0(makeName(x@args[[1L]]), ".", suffix)
})
setMethod("makeName", "SolrFunctionExpression", function(x) {
as.character(x@name)
})
imputeStatNames <- function(x) {
needsName <- if (is.null(names(x))) {
rep(TRUE, length(x))
} else {
names(x) == ""
}
names(x)[needsName] <- vapply(x[needsName], makeName, character(1L))
x
}
ensureNamesForJSON <- function(x) {
if (is.null(names(x))) {
names(x) <- character(0L)
}
x
}
statsParams <- function(x, grouping, ..., .stats=list()) {
requests <- mapply(deferTranslation,
expr=as.list(substitute(list(...))[-1L]),
env=top_prenv_dots(...),
MoreArgs=list(x=x, target=SolrAggregateCall(),
grouping=grouping))
requests <- imputeStatNames(requests)
ensureNamesForJSON(c(requests, .stats))
}
cutLabelsToLucene <- function(x) {
chartr("()", "{}", sub(",", " TO ", sub("-?Inf", "*", x)))
}
### FIXME: no counting of NAs for date faceting
### - could get closer with facet.range.other
checkSolrFacetBound <- function(x) {
if (is.numeric(x) || is(x, "POSIXt") || is(x, "Date")) {
x
} else {
stop("unsupported breaks type")
}
}
checkSolrFacetGap <- function(x) {
if (is.numeric(x) || is(x, "difftime")) {
x
} else {
stop("unsupported breaks type")
}
}
unique.difftime <- function(x) {
ans <- NextMethod()
attributes(ans) <- attributes(x)
ans
}
facet_cut <- function(x, breaks, include.lowest = FALSE, right = TRUE) {
var <- deparse(substitute(x))
if (length(gap <- unique(diff(breaks))) == 1L) {
facet.include <- if (right) "upper" else "lower"
if (include.lowest) {
facet.include <- paste0(facet.include, ",", "edge")
}
list(type="range",
field=var,
start=checkSolrFacetBound(min(breaks)),
end=checkSolrFacetBound(max(breaks)),
gap=checkSolrFacetGap(gap),
include=facet.include)
}
else {
### TODO: use interval facet here, once it is
### supported by the JSON API. Interval facets are actually so general
### that one could implement counting of genomic overlaps. Especially
### if the JSON API kept the interval syntax terse.
stop("non-uniform cut() breaks not yet supported")
}
}
mergeFacetParams <- function(x, params, terms, where, grouping, ...) {
if (is.null(params)) {
params <- list()
}
term <- terms[[1L]]
pterm <- params[[deparse(term)]]
if (length(terms) > 1L) {
if (is.null(pterm)) {
pterm <- facetParams(x, stripI(term), where, grouping)
}
pterm$facet <- mergeFacetParams(x, pterm$facet, terms[-1L],
where, grouping, ...)
} else {
newfacet <- facetParams(x, stripI(term), where, grouping, ...)
subfacets <- pterm$facet[vapply(pterm$facet, is.list, logical(1L))]
newfacet$facet <- structure(c(newfacet$facet, subfacets),
class="facetlist")
newfacet$nfq <- sum(names(params(x)) == "fq")
pterm <- structure(newfacet, class="facet")
}
params[[deparse(term)]] <- pterm
if (pterm$type == "query") {
not_pterm <- pterm
not_pterm$q@src@expr <- call("!", pterm$q@src@expr)
params[[paste0("_not_", deparse(term))]] <- not_pterm
}
params
}
faceted <- function(x) {
!is.null(json(x)$facet)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Request handler
###
requestHandler <- function(x) params(x)$qt
`requestHandler<-` <- function(x, value) {
if (!is.null(value) && !isSingleString(value)) {
stop("request handler must be a single string, or NULL")
}
params(x)$qt <- value
x
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Response format
###
typeToFormat <- c(list = "json", data.frame = "csv", XMLDocument = "xml")
responseType <- function(x) {
if (is.null(params(x)$wt)) {
NULL
} else {
names(typeToFormat)[match(params(x)$wt, typeToFormat)]
}
}
`responseType<-` <- function(x, value) {
if (!isSingleString(value)) {
stop("'value' must be a single, non-NA string")
}
format <- typeToFormat[value]
if (is.na(format)) {
stop("no format for response type: ", value)
}
params(x)$wt <- format
if (format == "json") {
params(x)$json.nl <- "map"
params(x)$csv.null <- NULL
} else if (format == "csv") {
params(x)$json.nl <- NULL
params(x)$csv.null <- "NA"
}
x
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Coercion
###
paramToCSV <- function(x) {
if (!is.null(names(x)))
x <- .qualifyByName(x, ":")
if (length(x) > 0L)
paste(x, collapse=",")
else x
}
### FIXME: In R <= 3.2.0, rapply() strips attributes. Thus, we need to
### process the parameters in one pass. Since rapply() is S3 based
### (only considers class attribute), and the different methods expect
### different arguments, it seems appropriate to use an S3 generic.
### We ended up writing our own rapply2(), because we want to apply
### the function to any node, not just the leaves.
translateParam <- function(x, ...) UseMethod("translateParam")
translateParam.TranslationRequest <- function(x, context, ...) {
ans <- eval(x, context)
if (identical(ans, solrNA)) NULL else ans
}
translateParam.facet <- function(x, fq, ...) {
if (!is.null(x$nfq)) {
x$excludeTags <- tail(fq, length(fq) - x$nfq)
x$nfq <- NULL
}
if (length(x$facet) == 0L) {
x$facet <- NULL
}
x
}
translateParam.facetlist <- function(x, ...) {
## This must be a well-known functional construct, does it have a name?
getChildren <- function(xi) {
child <- child(xi)
if (!is.null(child)) {
c(child, getChildren(child))
}
}
children <- unlist(unname(lapply(x, getChildren)))
x[vapply(children, hiddenName, character(1L))] <- children
x
}
getFqTags <- function(x) {
unname(vapply(x[names(x) == "fq"], tag, character(1L)))
}
translateBoundsParams <- function(p, nrows) {
ans_start <- 0L
ans_rows <- .Machine$integer.max
stopifnot(identical(length(p$start), length(p$rows)))
for (i in seq_along(p$start)) {
head_minus <- p$rows[i] < 0L
if (isTRUE(head_minus)) {
ans_rows <- min(ans_rows, nrows) + p$rows[i]
} else {
ans_rows <- min(ans_rows, p$rows[i], na.rm=TRUE)
}
tail_plus <- p$start[i] < 0L
if (tail_plus) {
ans_start <- ans_start + min(ans_rows, nrows) + p$start[i]
if (is.na(p$rows[i]))
ans_rows <- min(ans_rows, abs(p$start[i]))
} else {
ans_start <- ans_start + p$start[i]
if (is.na(p$rows[i]))
ans_rows <- min(ans_rows, nrows) - p$start[i]
}
}
p$start <- ans_start
p$rows <- ans_rows
p
}
translateParams <- function(p, core, nrows) {
p <- translateBoundsParams(p, nrows)
### FIRST TIME EVER USING rapply()!!!! Unfortunately, had to write our own.
rreplace(p, translateParam,
c("TranslationRequest", "facet", "facetlist"),
context=core, fq=getFqTags(p))
}
setMethod("translate", c("SolrQuery", "missing"), function(x, target, core) {
params(x) <- translateParams(params(x), core,
resultLength(core, x))
params(x)$fl <- Filter(Negate(is.null), params(x)$fl)
params(x)$sort <- Filter(Negate(is.null), params(x)$sort)
x
})
solrFormat <- function(x, ...) UseMethod("solrFormat")
solrFormat.POSIXt <- function(x, ...) {
toSolr(x, new("solr.DateField"))
}
solrFormat.Date <- function(x, ...) {
solrFormat(as.POSIXct(x), ...)
}
solrFormat.difftime <- function(x, ...) {
paste0("+", x, toupper(attr(x, "units")))
}
solrFormat.default <- function(x, ...) {
if (is.numeric(x) || is.logical(x)) {
x
} else {
as.character(x)
}
}
paramsAsCharacter <- function(p) {
p <- rapply(p, solrFormat, how="replace")
p$sort <- paramToCSV(p$sort)
p$fl <- paramToCSV(p$fl)
if (!is.null(p[["json"]])) # partial match hits 'json.nl'
p[["json"]] <- toJSON(p[["json"]])
storage.mode(p) <- "character"
p
}
setMethod("as.character", "SolrQuery",
function(x) paramsAsCharacter(params(x)))
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Utilities related to the 'fl' parameter
###
### This took some thought. The field restriction overrides the
### previous 'fl' parameter, except where it was adding new fields
### (computed or aliased). Those are kept iff they match the new
### restriction. This treats the field restriction almost like a
### "clip" in computer graphics. It can be reset. However, the
### high-level API requires selections be made from the current clip.
restrictToFields <- function(x, fields) {
fl <- params(x)$fl
names <- ifelse(nzchar(names(fl)), names(fl), NA_character_)
globs <- grepl("*", fields, fixed=TRUE)
exactMatch <- match(fields[!globs], names)
globMatchMatrix <- vapply(glob2rx(fields[globs]), grepl, names,
FUN.VALUE=logical(length(names)))
globMatch <- which(rowSums(globMatchMatrix) > 0L)
params(x)$fl <- c(fl[sort(c(exactMatch, globMatch))],
setdiff(fields, names[exactMatch]))
x
}
flNames <- function(fl) {
if (is.null(names(fl))) {
as.character(fl)
} else {
ans <- names(fl)
ans[ans == ""] <- as.character(fl[ans == ""])
ans
}
}
flIsPattern <- function(query) {
fl <- params(query)$fl
setNames(grepl("*", fl, fixed=TRUE), flNames(fl))
}
sortFieldsByQuery <- function(x, query) {
isPattern <- flIsPattern(query)
patterns <- which(isPattern)
m <- globMatchMatrix(names(patterns), x)
patterns <- patterns[max.col(m, ties.method="first")]
matched <- rowSums(m) > 0L
aliases <- which(!isPattern)
unique(c(names(aliases), x[matched])[order(c(aliases, patterns[matched]))])
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Show
###
sortForShow <- function(x) {
requests <- vapply(x, is, logical(1L), "TranslationRequest")
decreasing <- vapply(x[requests],
function(s) s@target@decreasing, logical(1L))
str <- paste0("`", vapply(x, as.character, character(1L)), "`")
str[requests] <- paste0(":", str[requests], ifelse(decreasing, "v", "^"))
str
}
groupForShow <- function(x) {
c(x[names(x) == "group.field"],
paste0("`", lapply(x[names(x) == "group.func"], as.character), "`"))
}
facetForShow <- function(x) {
if (is(x, "TranslationRequest"))
return(as.character(x))
if (x$type == "query") {
as.character(x$q)
} else if (x$type == "range") {
deparse(substitute(cut(field, seq(start, end, gap)), x))
} else {
x$field
}
}
facetsForShow <- function(x) {
vapply(x, facetForShow, character(1L))
}
showLine <- function(...) {
cat(labeledLine(...))
}
setMethod("show", "SolrQuery", function(object) {
cat("SolrQuery object\n")
p <- params(object)
fq <- p[names(p) == "fq"]
if (length(fq) > 0L)
showLine("subset", paste0("`", lapply(fq, as.character), "`"))
if (!identical(p$fl, list("*")))
showLine("select", p$fl)
if (!is.null(p$sort))
showLine("sort", sortForShow(p$sort))
if (grouped(object))
showLine("group", groupForShow(p))
if (faceted(object))
showLine("facet", facetsForShow(json(object)$facet))
if (!identical(p$start, 0L))
showLine("start", p$start[-1L])
if (!identical(p$rows, .Machine$integer.max))
showLine("rows", p$rows[-1L])
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.