Nothing
#' Parse raw data from solr_search, solr_facet, or solr_highlight.
#'
#' See details.
#'
#' @import XML rjson assertthat
#' @importFrom plyr rbind.fill
#' @param input Output from solr_facet
#' @param parsetype One of 'list' or 'df' (data.frame)
#' @param concat Character to conactenate strings by, e.g,. ',' (character). Used
#' in solr_parse.sr_search only.
#' @details This is the parser used internally in solr_facet, but if you output raw
#' data from solr_facet using raw=TRUE, then you can use this function to parse that
#' data (a sr_facet S3 object) after the fact to a list of data.frame's for easier
#' consumption. The data format type is detected from the attribute "wt" on the
#' sr_facet object.
#' @export
solr_parse <- function(input, parsetype, concat){
UseMethod("solr_parse")
}
#' @method solr_parse sr_facet
#' @export
#' @rdname solr_parse
solr_parse.sr_facet <- function(input, parsetype=NULL, concat=',')
{
assert_that(is(input, "sr_facet"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
# Facet queries
if(wt=='json'){
fqdat <- input$facet_counts$facet_queries
if(length(fqdat)==0){
fqout <- NULL
} else
{
fqout <- data.frame(term=names(fqdat), value=do.call(c, fqdat), stringsAsFactors=FALSE)
}
row.names(fqout) <- NULL
} else
{
nodes <- xpathApply(input, '//lst[@name="facet_queries"]//int')
if(length(nodes)==0){ fqout <- NULL } else { fqout <- nodes }
}
# facet fields
if(wt=='json'){
ffout <- lapply(input$facet_counts$facet_fields, function(x){
data.frame(do.call(rbind, lapply(seq(1, length(x), by=2), function(y){
x[c(y, y+1)]
})), stringsAsFactors=FALSE)
})
} else
{
nodes <- xpathApply(input, '//lst[@name="facet_fields"]//lst')
parselist <- function(x){
tmp <- xmlToList(x)
do.call(rbind.fill, lapply(tmp[!names(tmp) %in% ".attrs"], data.frame, stringsAsFactors=FALSE))
}
ffout <- lapply(nodes, parselist)
names(ffout) <- sapply(nodes, xmlAttrs)
}
# Facet dates
if(wt=='json'){
if(length(input$facet_counts$facet_dates)==0){
datesout <- NULL
} else
{
datesout <- lapply(input$facet_counts$facet_dates, function(x){
x <- x[!names(x) %in% c('gap','start','end')]
x <- data.frame(date=names(x), value=do.call(c, x), stringsAsFactors=FALSE)
row.names(x) <- NULL
x
})
}
} else
{
nodes <- xpathApply(input, '//lst[@name="facet_dates"]//int')
if(length(nodes)==0){ datesout <- NULL } else { datesout <- nodes }
}
# Facet ranges
if(wt=='json'){
if(length(input$facet_counts$facet_ranges)==0){
rangesout <- NULL
} else
{
rangesout <- lapply(input$facet_counts$facet_ranges, function(x){
x <- x[!names(x) %in% c('gap','start','end')]$counts
data.frame(do.call(rbind, lapply(seq(1, length(x), by=2), function(y){
x[c(y, y+1)]
})), stringsAsFactors=FALSE)
})
}
} else
{
nodes <- xpathApply(input, '//lst[@name="facet_ranges"]//int')
if(length(nodes)==0){ rangesout <- NULL } else { rangesout <- nodes }
}
# output
return( list(facet_queries = replacelen0(fqout),
facet_fields = replacelen0(ffout),
facet_dates = replacelen0(datesout),
facet_ranges = replacelen0(rangesout)) )
}
#' @method solr_parse sr_high
#' @export
#' @rdname solr_parse
solr_parse.sr_high <- function(input, parsetype='list', concat=',')
{
assert_that(is(input, "sr_high"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
if(wt=='json'){
if(parsetype=='df'){
dat <- input$highlight
# highout <- data.frame(term=names(dat), value=do.call(c, dat), stringsAsFactors=FALSE)
highout <- data.frame(cbind(names=names(dat), do.call(rbind, dat)))
row.names(highout) <- NULL
} else
{
highout <- input$highlight
}
} else
{
highout <- xpathApply(input, '//lst[@name="highlighting"]//lst', xmlToList)
tmptmp <- lapply(highout, function(x){
meta <- x$.attrs[[1]]
names(x) <- NULL
as.list(c(meta = meta,
sapply(x[-length(x)], function(y){
tmp <- y$str[[1]]
names(tmp) <- y$.attrs[[1]]
tmp
})
))
})
if(parsetype=='df'){
highout <- do.call(rbind.fill, lapply(tmptmp, data.frame, stringsAsFactors=FALSE))
# dois <- xpathApply(input, '//lst[@name="highlighting"]//lst')
# dois <- sapply(dois, function(x) xmlAttrs(x)['name'], USE.NAMES=FALSE)
# nodes <- xpathApply(input, '//arr')
# nn <- unique(sapply(nodes, function(x) xmlAttrs(x)['name'], USE.NAMES=FALSE))
# data <- lapply(nn, function(x) xpathApply(input, sprintf('//arr[@name="%s"]', x), xmlValue))
# highout <- data.frame(do.call(cbind, data))
# names(highout) <- nn
} else
{
highout <- tmptmp
}
}
return( highout )
}
#' @method solr_parse sr_search
#' @export
#' @rdname solr_parse
solr_parse.sr_search <- function(input, parsetype='list', concat=',')
{
assert_that(is(input, "sr_search"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
if(wt=='json'){
if(parsetype=='df'){
dat <- input$response$docs
dat2 <- lapply(dat, function(x){
lapply(x, function(y){
if(length(y) > 1){
paste(y, collapse=concat)
} else { y }
})
})
datout <- do.call(rbind.fill, lapply(dat2, data.frame, stringsAsFactors=FALSE))
} else
{
# datout <- input$response$docs
datout <- input
}
} else
{
temp <- xpathApply(input, '//doc')
tmptmp <- lapply(temp, function(x){
tt <- xmlToList(x)
uu <- lapply(tt, function(y){
u <- y$text[[1]]
names(u) <- y$.attrs[[1]]
u
})
names(uu) <- NULL
as.list(unlist(uu))
})
if(parsetype=='df'){
datout <- do.call(rbind.fill, lapply(tmptmp, data.frame, stringsAsFactors=FALSE))
} else
{
datout <- tmptmp
}
}
return( datout )
}
#' @method solr_parse sr_mlt
#' @export
#' @rdname solr_parse
solr_parse.sr_mlt <- function(input, parsetype='list', concat=',')
{
assert_that(is(input, "sr_mlt"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
if(wt=='json'){
if(parsetype=='df'){
res <- input$response
reslist <- lapply(res$docs, function(y){
lapply(y, function(z){
if(length(z) > 1){
paste(z, collapse=concat)
} else { z }
})
})
resdat <- data.frame(do.call(rbind.fill, lapply(reslist, data.frame)),
stringsAsFactors=FALSE)
dat <- input$moreLikeThis
dat2 <- lapply(dat, function(x){
lapply(x$docs, function(y){
lapply(y, function(z){
if(length(z) > 1){
paste(z, collapse=concat)
} else { z }
})
})
})
datmlt <- list()
for(i in seq_along(dat)){
datmlt[[names(dat[i])]] <-
do.call(rbind.fill, lapply(dat[[i]]$docs, function(y){
data.frame(lapply(y, function(z){
if(length(z) > 1){
paste(z, collapse=concat)
} else { z }
}), stringsAsFactors=FALSE)
}))
}
# datmlt <- do.call(rbind.fill, lapply(dat2, data.frame, stringsAsFactors=FALSE))
# row.names(datmlt) <- NULL
datout <- list(docs=resdat, mlt=datmlt)
} else
{
datout <- input$moreLikeThis
}
} else
{
res <- xpathApply(input, '//result[@name="response"]//doc')
resdat <- do.call(rbind.fill, lapply(res, function(x){
tmp <- xmlChildren(x)
tmp2 <- sapply(tmp, xmlValue)
names2 <- sapply(tmp, xmlGetAttr, name="name")
names(tmp2) <- names2
data.frame(as.list(tmp2), stringsAsFactors=FALSE)
}))
temp <- xpathApply(input, '//doc')
tmptmp <- lapply(temp, function(x){
tt <- xmlToList(x)
uu <- lapply(tt, function(y){
u <- y$text[[1]]
names(u) <- y$.attrs[[1]]
u
})
names(uu) <- NULL
as.list(unlist(uu))
})
if(parsetype=='df'){
datout <- do.call(rbind.fill, lapply(tmptmp, data.frame, stringsAsFactors=FALSE))
} else
{
datout <- tmptmp
}
}
return( datout )
}
#' @method solr_parse sr_stats
#' @export
#' @rdname solr_parse
solr_parse.sr_stats <- function(input, parsetype='list', concat=',')
{
assert_that(is(input, "sr_stats"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
if(wt=='json'){
if(parsetype=='df'){
dat <- input$stats$stats_fields
if(length(dat)==1){
datout <- data.frame(dat[[1]][!names(dat[[1]]) %in% 'facets'])
} else {
dat2 <- lapply(dat, function(x){
data.frame(x[!names(x) %in% 'facets'])
})
dat_reg <- do.call(rbind, dat2)
# facets
dat_facet <- lapply(dat, function(x){
facetted <- x[names(x) %in% 'facets'][[1]]
if(length(facetted) == 1){
df <- do.call(rbind, lapply(facetted[[1]], function(z) data.frame(z[!names(z) %in% 'facets'])))
df <- data.frame(df, row.names(df))
names(df)[ncol(df)] <- names(facetted)
} else {
df <- lapply(facetted, function(z){
dd <- do.call(rbind, lapply(z, function(zz) data.frame(zz[!names(zz) %in% 'facets'])))
dd <- data.frame(dd, row.names(dd))
row.names(dd) <- NULL
names(dd)[ncol(dd)] <- "facet_field"
dd
})
}
})
datout <- list(data=dat_reg, facet=dat_facet)
}
} else
{
dat <- input$stats$stats_fields
# w/o facets
dat_reg <- lapply(dat, function(x){
x[!names(x) %in% 'facets']
})
# just facets
dat_facet <- lapply(dat, function(x){
facetted <- x[names(x) %in% 'facets'][[1]]
if(length(facetted) == 1){
lapply(facetted[[1]], function(z) z[!names(z) %in% 'facets'])
} else {
df <- lapply(facetted, function(z){
lapply(z, function(zz) zz[!names(zz) %in% 'facets'])
})
}
})
datout <- list(data=dat_reg, facet=dat_facet)
}
} else
{
temp <- xpathApply(input, '//lst/lst[@name="stats_fields"]/lst')
if(parsetype=='df'){
# w/o facets
dat_reg <- do.call(rbind.fill, lapply(temp, function(h){
tt <- xmlChildren(h)
uu <- tt[!names(tt) %in% 'lst']
vals <- sapply(uu, xmlValue)
names2 <- sapply(uu, xmlGetAttr, name="name")
names(vals) <- names2
data.frame(rbind(vals), stringsAsFactors=FALSE)
}))
# just facets
dat_facet <- lapply(temp, function(e){
tt <- xmlChildren(e)
uu <- tt[names(tt) %in% 'lst']
lapply(xmlChildren(uu$lst), function(f){
do.call(rbind.fill, lapply(xmlChildren(f), function(g){
ttt <- xmlChildren(g)
uuu <- ttt[!names(ttt) %in% 'lst']
vals <- sapply(uuu, xmlValue)
names2 <- sapply(uuu, xmlGetAttr, name="name")
names(vals) <- names2
data.frame(rbind(vals), stringsAsFactors=FALSE)
}))
})
})
datout <- list(data=dat_reg, facet=dat_facet)
} else
{
dat_reg <- lapply(temp, function(h){
title <- xmlAttrs(h)[[1]]
tt <- xmlChildren(h)
uu <- tt[!names(tt) %in% 'lst']
vals <- sapply(uu, xmlValue)
names2 <- sapply(uu, xmlGetAttr, name="name")
names(vals) <- names2
ss <- list(x=as.list(vals))
names(ss) <- title
ss
})
# just facets
dat_facet <- lapply(temp, function(e){
title1 <- xmlAttrs(e)[[1]]
tt <- xmlChildren(e)
uu <- tt[names(tt) %in% 'lst']
ssss <- lapply(xmlChildren(uu$lst), function(f){
title2 <- xmlAttrs(f)[[1]]
sss <- lapply(xmlChildren(f), function(g){
title3 <- xmlAttrs(g)[[1]]
ttt <- xmlChildren(g)
uuu <- ttt[!names(ttt) %in% 'lst']
vals <- sapply(uuu, xmlValue)
names2 <- sapply(uuu, xmlGetAttr, name="name")
names(vals) <- names2
ss <- list(x=as.list(vals))
names(ss) <- eval(title3)
ss
})
names(sss) <- rep(eval(title2), length(names(sss)))
sss
})
names(ssss) <- rep(eval(title1), length(names(ssss)))
ssss
})
datout <- list(data=dat_reg, facet=dat_facet)
}
}
return( datout )
}
#' @method solr_parse sr_group
#' @export
#' @rdname solr_parse
solr_parse.sr_group <- function(input, parsetype='list', concat=',')
{
assert_that(is(input, "sr_group"))
wt <- attributes(input)$wt
input <- switch(wt,
xml = xmlParse(input),
json = rjson::fromJSON(input))
if(wt=='json'){
if(parsetype=='df'){
if(names(input) == 'response'){
datout <- cbind(data.frame(numFound=input[[1]]$numFound,
start=input[[1]]$start),
do.call(rbind.fill, lapply(input[[1]]$docs, data.frame, stringsAsFactors=FALSE)))
} else
{
dat <- input$grouped
if(length(dat)==1){
if('groups' %in% names(dat[[1]])){
datout <- dat[[1]]$groups
datout <- do.call(rbind.fill, lapply(datout, function(x){
df <- data.frame(groupValue=ifelse(is.null(x$groupValue),"none",x$groupValue),
numFound=x$doclist$numFound,
start=x$doclist$start)
cbind(df, do.call(rbind.fill,
lapply(x$doclist$docs, function(z){
data.frame(lapply(z, function(zz){
if(length(zz) > 1){
paste(zz, collapse=concat)
} else { zz }
}), stringsAsFactors=FALSE)
})
))
}))
} else
{
datout <- cbind(data.frame(numFound=dat[[1]]$doclist$numFound,
start=dat[[1]]$doclist$start),
do.call(rbind.fill, lapply(dat[[1]]$doclist$docs, data.frame, stringsAsFactors=FALSE)))
}
} else {
if('groups' %in% names(dat[[1]])){
datout <- lapply(dat, function(y){
y <- y$groups
do.call(rbind.fill, lapply(y, function(x){
df <- data.frame(groupValue=ifelse(is.null(x$groupValue),"none",x$groupValue),
numFound=x$doclist$numFound,
start=x$doclist$start, stringsAsFactors=FALSE)
cbind(df, do.call(rbind.fill, lapply(x$doclist$docs, data.frame, stringsAsFactors=FALSE)))
}))
})
} else
{
datout <- do.call(rbind.fill, lapply(dat, function(x){
df <- data.frame(numFound=x$doclist$numFound,
start=x$doclist$start, stringsAsFactors=FALSE)
cbind(df, do.call(rbind.fill, lapply(x$doclist$docs, data.frame, stringsAsFactors=FALSE)))
}))
}
}
}
} else
{
datout <- input$grouped
}
} else
{
temp <- xpathApply(input, '//lst/lst[@name="grouped"]/lst')
if(parsetype=='df'){
datout <- "not done yet"
} else
{
datout <- "not done yet"
}
}
return( datout )
}
# small function to replace elements of length 0 with NULL
replacelen0 <- function(x) if(length(x) < 1){ NULL } else { x }
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.