#' Parse raw data from solr_search, solr_facet, or solr_highlight.
#'
#' @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 = NULL, concat) {
UseMethod("solr_parse")
}
#' @export
solr_parse.default <- function(input, parsetype=NULL, concat=',') {
stop("no 'solr_parse' method for ", class(input), call. = FALSE)
}
#' @export
solr_parse.ping <- function(input, parsetype=NULL, concat=',') {
wt <- attributes(input)$wt
parse_it(input, wt)
}
#' @export
solr_parse.update <- function(input, parsetype=NULL, concat=',') {
wt <- attributes(input)$wt
switch(wt,
xml = xml2::read_xml(unclass(input)),
json = jsonlite::fromJSON(input, simplifyDataFrame = FALSE,
simplifyMatrix = FALSE),
csv = jsonlite::fromJSON(input, simplifyDataFrame = FALSE,
simplifyMatrix = FALSE)
)
}
#' @export
solr_parse.sr_facet <- function(input, parsetype = NULL, concat = ',') {
if (inherits(unclass(input), "character")) {
input <- parse_ch(input, parsetype, concat)
}
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
# Facet queries
if (wt == 'json') {
fqdat <- input$facet_counts$facet_queries
if (length(fqdat) == 0) {
fqout <- NULL
} else {
fqout <- tibble::tibble(
term = names(fqdat),
value = do.call(c, fqdat)
)
}
row.names(fqout) <- NULL
} else {
nodes <- xml2::xml_find_all(input, '//lst[@name="facet_queries"]//int')
if (length(nodes) == 0) {
fqout <- NULL
} else {
fqout <- tibble::tibble(
term = xml2::xml_attr(nodes, "name"),
value = xml2::xml_text(nodes)
)
}
}
# facet fields
if (wt == 'json') {
ffout <- lapply(input$facet_counts$facet_fields, function(x) {
tibble::as_tibble(
stats::setNames(
do.call(rbind.data.frame, lapply(seq(1, length(x), by = 2), function(y) {
x[c(y, y + 1)]
})), c('term', 'value')
)
)
})
} else {
nodes <- xml_find_all(input, '//lst[@name="facet_fields"]//lst')
ffout <- lapply(nodes, function(z) {
ch <- xml_children(z)
tibble::tibble(
term = vapply(ch, xml_attr, "", attr = "name"),
value = vapply(ch, xml_text, "")
)
})
names(ffout) <- xml_attr(nodes, "name")
}
# facet pivot
if (wt == 'json') {
fpout <- NULL
pivot_input <- jsonlite::fromJSON(jsonlite::toJSON(input))$facet_count$facet_pivot[[1]]
if (length(pivot_input) != 0) {
fpout <- list()
pivots_left <- ('pivot' %in% names(pivot_input))
if (pivots_left) {
infinite_loop_check <- 1
while (pivots_left & infinite_loop_check < 100) {
stopifnot(is.data.frame(pivot_input))
flattened_result <- pivot_flatten_tabular(pivot_input)
fpout <- c(fpout, list(flattened_result$parent))
pivot_input <- flattened_result$flattened_pivot
pivots_left <- ('pivot' %in% names(pivot_input))
infinite_loop_check <- infinite_loop_check + 1
}
fpout <- c(fpout, list(flattened_result$flattened_pivot))
} else {
fpout <- c(fpout, list(pivot_input))
}
fpout <- lapply(fpout, collapse_pivot_names)
names(fpout) <- sapply(fpout, FUN = function(x) {
paste(head(names(x), -1), collapse = ",")
})
}
} else {
message('facet.pivot results are not supported with XML response types, use wt="json"')
fpout <- NULL
}
# Facet dates
if (wt == 'json') {
datesout <- NULL
if (length(input$facet_counts$facet_dates) != 0) {
datesout <- lapply(input$facet_counts$facet_dates, function(x) {
x <- x[!names(x) %in% c('gap','start','end')]
tibble::tibble(date = names(x), value = do.call(c, x))
})
}
} else {
nodes <- xml_find_all(input, '//lst[@name="facet_dates"]')[[1]]
if (length(nodes) != 0) {
datesout <- stats::setNames(lapply(xml_children(nodes), function(z) {
z <- xml_find_all(z, 'int')
tibble::tibble(
date = xml2::xml_attr(z, "name"),
value = xml2::xml_text(z)
)
}), xml_attr(xml_children(nodes), "name"))
}
}
# Facet ranges
rangesout <- NULL
if (wt == 'json') {
if (length(input$facet_counts$facet_ranges) != 0) {
rangesout <- lapply(input$facet_counts$facet_ranges, function(x){
x <- x[!names(x) %in% c('gap','start','end')]$counts
tibble::as_tibble(
stats::setNames(
do.call(rbind.data.frame, lapply(seq(1, length(x), by = 2), function(y){
x[c(y, y + 1)]
})),
c('term', 'value')
)
)
})
}
} else {
nodes <- xml_find_all(input, '//lst[@name="facet_ranges"]//lst[not(@name="counts")]')
if (length(nodes) != 0) {
rangesout <- stats::setNames(lapply(nodes, function(z) {
z <- xml_children(xml_find_first(z, 'lst[@name="counts"]'))
tibble::tibble(
term = xml2::xml_attr(z, "name"),
value = xml2::xml_text(z)
)
}), xml_attr(nodes, "name"))
}
}
# output
res <- list(facet_queries = replacelen0(fqout),
facet_fields = replacelen0(ffout),
facet_pivot = replacelen0(fpout),
facet_dates = replacelen0(datesout),
facet_ranges = replacelen0(rangesout))
res <- if (length(sc(res)) == 0) list() else res
# attributes
if (!is.null(next_cursor_mark)) {
res <- add_atts(res, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
res <- add_atts(res, list(responseHeader = response_header))
}
return( res )
}
#' @export
#' @rdname solr_parse
solr_parse.sr_high <- function(input, parsetype='list', concat=',') {
if (inherits(unclass(input), "character")) input <- parse_ch(input, parsetype, concat)
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
if (wt == 'json') {
if (parsetype == 'df') {
dat <- input$highlight
df <- dplyr::bind_rows(lapply(dat, function(z) {
as_tibble(lapply(z, function(w) {
if (length(w) > 1) paste0(w, collapse = "") else w
}))
}))
if (NROW(df) == 0) {
highout <- tibble::tibble()
} else {
highout <- tibble::add_column(df, names = names(dat), .before = TRUE)
}
} else {
highout <- input$highlight
}
} else {
highout <- xml_children(xml_find_all(input, '//lst[@name="highlighting"]'))
tmptmp <- lapply(highout, function(z) {
c(
names = xml_attr(z, "name"),
sapply(
xml_children(z),
function(w) as.list(stats::setNames(xml_text(w), xml_attr(w, "name"))))
)
})
if (parsetype == 'df') {
highout <- dplyr::bind_rows(lapply(tmptmp, as_tibble))
} else {
highout <- tmptmp
}
}
# attributes
if (!is.null(next_cursor_mark)) {
highout <- add_atts(highout, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
highout <- add_atts(highout, list(responseHeader = response_header))
}
return( highout )
}
#' @export
#' @rdname solr_parse
solr_parse.sr_search <- function(input, parsetype = 'list', concat = ',') {
if (inherits(unclass(input), "character")) input <- parse_ch(input, parsetype, concat)
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
if (wt == 'json') {
if (parsetype == 'df') {
dat <- input$response$docs
dat2 <- lapply(dat, function(x) {
lapply(x, function(y) {
tmp <- if (length(y) > 1) {
paste(y, collapse = concat)
} else {
y
}
if (inherits(y, "list")) unlist(tmp) else tmp
})
})
datout <- dplyr::bind_rows(lapply(dat2, as_tibble))
} else {
datout <- input$response$docs
}
datout <- add_atts(datout, popp(input$response, "docs"))
} else if (wt == "xml") {
temp <- xml2::xml_find_all(input, '//doc')
tmptmp <- lapply(temp, function(x) {
sapply(xml2::xml_children(x), nmtxt)
})
if (parsetype == 'df') {
datout <- dplyr::bind_rows(lapply(tmptmp, as_tibble))
} else {
datout <- tmptmp
}
datout <- add_atts(datout, as.list(xml2::xml_attrs(xml2::xml_find_first(input, "result"))))
} else {
datout <- input
}
if (!is.null(next_cursor_mark)) {
datout <- add_atts(datout, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
datout <- add_atts(datout, list(responseHeader = response_header))
}
return( datout )
}
#' @export
#' @rdname solr_parse
solr_parse.sr_all <- function(input, parsetype = 'list', concat = ',') {
tmp <- list(
search = solr_parse.sr_search(unclass(input), parsetype, concat),
facet = solr_parse.sr_facet(unclass(input), parsetype, concat),
high = solr_parse.sr_high(unclass(input), parsetype, concat),
mlt = solr_parse.sr_mlt(unclass(input), parsetype, concat),
group = solr_parse.sr_group(unclass(input), parsetype, concat),
stats = solr_parse.sr_stats(unclass(input), parsetype, concat)
)
# drop attributes within each result, add to top level list
tmp <- lapply(tmp, function(z) {
attr(z, "nextCursorMark") <- NULL
attr(z, "responseHeader") <- NULL
z
})
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
if (!is.null(next_cursor_mark)) {
tmp <- add_atts(tmp, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
tmp <- add_atts(tmp, list(responseHeader = response_header))
}
return(tmp)
}
#' @export
#' @rdname solr_parse
solr_parse.sr_mlt <- function(input, parsetype = 'list', concat = ',') {
if (inherits(unclass(input), "character")) input <- parse_ch(input, parsetype, concat)
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
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 <- dplyr::bind_rows(lapply(reslist, as_tibble))
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)) {
attsdf <- as_tibble(popp(dat[[i]], "docs"))
df <- dplyr::bind_rows(lapply(dat[[i]]$docs, function(y) {
as_tibble(lapply(y, function(z) {
if (length(z) > 1) {
paste(z, collapse = concat)
} else {
z
}
}))
}))
if (NROW(df) == 0) {
df <- attsdf
} else {
df <- as_tibble(cbind(attsdf, df))
}
datmlt[[names(dat[i])]] <- df
}
datout <- list(docs = resdat, mlt = datmlt)
} else {
datout <- input$moreLikeThis
}
} else {
res <- xml_find_all(input, '//result[@name="response"]//doc')
resdat <- dplyr::bind_rows(lapply(res, function(x){
tmp <- sapply(xml_children(x), nmtxt)
as_tibble(tmp)
}))
temp <- xml_find_all(input, '//lst[@name="moreLikeThis"]')
tmptmp <- stats::setNames(lapply(xml_children(temp), function(z) {
lapply(xml_find_all(z, "doc"), function(w) {
sapply(xml_children(w), nmtxt)
})
}), xml_attr(xml_children(temp), "name"))
tmptmp <- Map(function(x, y) {
atts <- as.list(xml_attrs(y))
for (i in seq_along(atts)) {
attr(x, names(atts)[i]) <- atts[[i]]
}
x
},
tmptmp,
xml_children(temp)
)
if (parsetype == 'df') {
datmlt <- lapply(tmptmp, function(z) {
df <- dplyr::bind_rows(lapply(z, as_tibble))
atts <- attributes(z)
attsdf <- as_tibble(atts)
if (NROW(df) == 0) {
attsdf
} else {
as_tibble(cbind(attsdf, df))
}
})
datout <- list(docs = resdat, mlt = datmlt)
} else {
datout <- list(docs = resdat, mlt = tmptmp)
}
}
if (!is.null(next_cursor_mark)) {
datout <- add_atts(datout, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
datout <- add_atts(datout, list(responseHeader = response_header))
}
return( datout )
}
#' @export
#' @rdname solr_parse
solr_parse.sr_stats <- function(input, parsetype = 'list', concat = ',') {
if (inherits(unclass(input), "character")) input <- parse_ch(input, parsetype, concat)
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
if (wt == 'json') {
if (parsetype == 'df') {
dat <- input$stats$stats_fields
dat2 <- lapply(dat, function(x) {
# fill null's first
tmp <- x[!names(x) %in% 'facets']
tmp[sapply(tmp, class) == "NULL"] <- NA_character_
data.frame(tmp, stringsAsFactors = FALSE)
})
dat_reg <- do.call(rbind, dat2)
# parse the facets
if (length(dat[[1]]$facets) == 0) {
dat_facet <- NULL
} else {
dat_facet <- lapply(dat, function(x){
facetted <- x[names(x) %in% 'facets'][[1]]
if (length(facetted) == 1) {
df <- dplyr::bind_rows(
lapply(facetted[[1]], function(z) {
as_tibble(
lapply(z[!names(z) %in% 'facets'], function(w) {
if (length(w) == 0) "" else w
})
)
})
, .id = names(facetted))
} else {
df <- stats::setNames(lapply(seq.int(length(facetted)), function(n) {
dplyr::bind_rows(lapply(facetted[[n]], function(b) {
as_tibble(
lapply(b[!names(b) %in% 'facets'], function(w) {
if (length(w) == 0) "" else w
})
)
}), .id = names(facetted)[n])
}), names(facetted))
}
return(df)
})
}
datout <- list(data = dat_reg, facet = dat_facet)
} else {
dat <- input$stats$stats_fields
# w/o facets
dat_reg <- lapply(dat, function(x) {
# fill null's first
tmp <- x[!names(x) %in% 'facets']
tmp[sapply(tmp, class) == "NULL"] <- NA_character_
tmp
})
# just facets
dat_facet <- lapply(dat, function(x){
if (!'facets' %in% names(x)) return(list())
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 <- xml_find_all(input, '//lst/lst[@name="stats_fields"]/lst')
if (parsetype == 'df') {
# w/o facets
dat_reg <- dplyr::bind_rows(stats::setNames(lapply(temp, function(h){
as_tibble(popp(sapply(xml_children(h), nmtxt), "facets"))
}), xml_attr(temp, "name")), .id = "stat")
# just facets
dat_facet <- stats::setNames(lapply(temp, function(e){
tt <- xml_find_first(e, 'lst[@name="facets"]')
stats::setNames(lapply(xml_children(tt), function(f){
dplyr::bind_rows(stats::setNames(lapply(xml_children(f), function(g){
as_tibble(popp(sapply(xml_children(g), nmtxt), "facets"))
}), xml_attr(xml_children(f), "name")), .id = xml_attr(f, "name"))
}), xml_attr(xml_children(tt), "name"))
}), xml_attr(temp, "name"))
datout <- list(data = dat_reg, facet = dat_facet)
} else {
# w/o facets
dat_reg <- stats::setNames(lapply(temp, function(h){
popp(sapply(xml_children(h), nmtxt), "facets")
}), xml_attr(temp, "name"))
# just facets
dat_facet <- stats::setNames(lapply(temp, function(e){
tt <- xml_find_first(e, 'lst[@name="facets"]')
stats::setNames(lapply(xml_children(tt), function(f){
stats::setNames(lapply(xml_children(f), function(g){
popp(sapply(xml_children(g), nmtxt), "facets")
}), xml_attr(xml_children(f), "name"))
}), xml_attr(xml_children(tt), "name"))
}), xml_attr(temp, "name"))
datout <- list(data = dat_reg, facet = dat_facet)
}
}
if (!is.null(next_cursor_mark)) {
datout <- add_atts(datout, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
datout <- add_atts(datout, list(responseHeader = response_header))
}
datout <- if (length(Filter(length, datout)) == 0) NULL else datout
return( datout )
}
#' @export
#' @rdname solr_parse
solr_parse.sr_group <- function(input, parsetype = 'list', concat = ',') {
if (inherits(unclass(input), "character")) input <- parse_ch(input, parsetype, concat)
# collect attributes
wt <- attributes(input)$wt
next_cursor_mark <- input$nextCursorMark
response_header <- input$responseHeader
if (wt == 'json') {
if (parsetype == 'df') {
if ('response' %in% names(input)) {
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 <- xml_find_all(input, '//lst[@name="grouped"]/lst')
if (parsetype == 'df') {
datout <- stats::setNames(lapply(temp, function(e){
tt <- xml_find_first(e, 'arr[@name="groups"]')
dplyr::bind_rows(stats::setNames(lapply(xml_children(tt), function(f){
docc <- xml_find_all(f, 'result[@name="doclist"]/doc')
df <- dplyr::bind_rows(lapply(docc, function(g){
as_tibble(sapply(xml_children(g), nmtxt))
}))
add_column(
df,
numFound = xml_attr(xml_find_first(f, "result"), "numFound"),
start = xml_attr(xml_find_first(f, "result"), "start"),
.before = TRUE
)
}), vapply(xml_children(tt), function(z) xml_text(xml_find_first(z, "str")) %||% "", "")),
.id = "group"
)
}), xml_attr(temp, "name"))
} else {
datout <- stats::setNames(lapply(temp, function(e){
tt <- xml_find_first(e, 'arr[@name="groups"]')
stats::setNames(lapply(xml_children(tt), function(f){
docc <- xml_find_all(f, 'result[@name="doclist"]/doc')
lst <- lapply(docc, function(g){
sapply(xml_children(g), nmtxt)
})
list(
docs = lst,
numFound = xml_attr(xml_find_first(f, "result"), "numFound"),
start = xml_attr(xml_find_first(f, "result"), "start")
)
}), vapply(xml_children(tt), function(z) xml_text(xml_find_first(z, "str")) %||% "", ""))
}), xml_attr(temp, "name"))
}
}
if (!is.null(next_cursor_mark)) {
datout <- add_atts(datout, list(nextCursorMark = next_cursor_mark))
}
if (!is.null(response_header)) {
datout <- add_atts(datout, list(responseHeader = response_header))
}
return( datout )
}
# helper fxns ---------------------
nmtxt <- function(x) {
as.list(stats::setNames(xml2::xml_text(x), xml2::xml_attr(x, "name")))
}
add_atts <- function(x, atts = NULL) {
if (is.null(x)) return(x)
if (!is.null(atts)) {
for (i in seq_along(atts)) {
attr(x, names(atts)[i]) <- atts[[i]]
}
return(x)
} else {
return(x)
}
}
parse_it <- function(x, wt) {
switch(
wt,
xml = {
xml2::read_xml(unclass(x))
},
json = {
jsonlite::fromJSON(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE)
},
csv = {
tibble::as_tibble(
read.table(text = x, sep = ",", stringsAsFactors = FALSE,
header = TRUE, fill = TRUE, comment.char = "")
)
}
)
}
parse_ch <- function(x, parsetype, concat) {
parsed <- cont_parse(x, attr(x, "wt"))
structure(parsed, class = c(class(parsed), class(x)))
}
cont_parse <- function(x, wt) {
structure(parse_it(x, wt), wt = wt)
}
# facet.pivot helpers --------------
#' Flatten facet.pivot responses
#'
#' Convert a nested hierarchy of facet.pivot elements
#' to tabular data (rows and columns)
#'
#' @param df_w_pivot a \code{data.frame} with another
#' \code{data.frame} nested inside representing a
#' pivot reponse
#' @return a \code{data.frame}
#'
#' @keywords internal
pivot_flatten_tabular <- function(df_w_pivot){
# drop last column assumed to be named "pivot"
parent <- df_w_pivot[head(names(df_w_pivot),-1)]
pivot <- df_w_pivot$pivot
pp <- list()
for (i in 1:nrow(parent)) {
if ((!is.null(pivot[[i]])) && (nrow(pivot[[i]]) > 0)) {
# from parent drop last column assumed to be named "count" to not create duplicate columns of information
pp[[i]] <- data.frame(cbind(parent[i,], pivot[[i]], row.names = NULL))
}
}
flattened_pivot <- do.call('rbind', pp)
# return a tbl_df to flatten again if necessary
return(list(parent = parent, flattened_pivot = flattened_pivot))
}
#' Collapse Pivot Field and Value Columns
#'
#' Convert a table consisting of columns in sets of 3
#' into 2 columns assuming that the first column of every set of 3
#' (field) is duplicated throughout all rows and should be removed.
#' This type of structure is usually returned by facet.pivot responses.
#'
#' @param data a \code{data.frame} with every 2 columns
#' representing a field and value and the final representing
#' a count
#' @return a \code{data.frame}
#'
#' @keywords internal
collapse_pivot_names <- function(data){
# shift field name to the column name to its right
for (i in seq(1, ncol(data) - 1, by = 3)) {
names(data)[i + 1] <- data[1, i]
}
# remove columns with duplicating information (anything named field)
data <- data[-c(seq(1, ncol(data) - 1, by = 3))]
# remove vestigial count columns
if (ncol(data) > 2) {
data <- data[-c(seq(0, ncol(data) - 1, by = 2))]
}
names(data)[length(data)] <- 'count'
return(data)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.