Nothing
# Generics ---------------------------------------------------------------
#nolint start
#' Get and set slide analyses
#'
#' Slides are composed of analyses, which are effectively `CrunchCubes` with some
#' additional metadata. You can get and set a slide's Analysis Catalog with the
#' `analyses` method, and access an individual analysis with `analysis`. There
#' are also helpers to get and set the components of the analysis such as `filter()`,
#' `weight()`, `transforms()`, `displaySettings()` and `vizSpecs()`. You can also
#' get the `CrunchCube` from an analysis using `cube()`.
#'
#' For more complex objects like `displaySettings()`, `vizSpecs()` and `transforms()`,
#' the [API documentation](
#' https://crunch.io/api/reference/#patch-/datasets/-dataset_id-/decks/-deck_id-/slides/-slide_id-/analyses/-analysis_id-/)
#' provides more details.
#'
#' Advanced users of the API can assign a list to `analysis<-` to specify settings
#' on the analyses that are not otherwise available in `rcrunch`. The helpers
#' `formulaToSlideQuery()` and `slideQueryEnv()` help you create objects for the
#' `query` and `query_environment`.
#'
#' @param x a `CrunchSlide`, `AnalysisCatalog`, or `Analysis`
#' @param value for the setter, an object to set it
#' @param query For `formulaToSlideQuery()`, a formula that specifies the query, as in
#' `newSlide()`. See Details of [`crtabs()`] for more information.
#' @param dataset For `formulaToSlideQuery()`, a `CrunchDataset` that the variables in
#' `query` refer to.
#' @param weight For `slideQueryEnv()` a crunch variable to use as a weight or `NULL`
#' to indicate no weight should be used.
#' @param filter for `slideQueryEnv()`, a `CrunchFilter` or `CrunchExpression` to filter
#' the slide.
#' @param ... ignored
#'
#' @rdname analysis-methods
#' @export
#' @examples
#' \dontrun{
#' # Examples of setting analysis details (in general these setters work on
#' # the slide, analysis catalog and analysis, but for brevity the examples only
#' # show on the slide)
#'
#' # Change the filter
#' filters(slide) <- NULL # to remove a filter
#' filters(slide) <- filters(ds)[["My filter"]]
#' filters(slide) <- list( # Can set multiple filter
#' filters(ds)[["My filter"]],
#' ds$age_grp == "18-35"
#' )
#' filters(deck) <- filters(ds)[["My filter"]] # Can set the same filter on a whole deck too
#'
#' # Change the weight
#' weight(slide) <- NULL # to remove
#' weight(slide) <- ds$weight
#' weight(deck) <- ds$weight # Can set the same weight on a whole deck too
#'
#' # Change the transforms
#' transforms(slide) <- list(rows_dimension = makeDimTransform(hide = "Neutral"))
#'
#' # Change the displaySettings
#' displaySettings(slide) <- list(vizType = "groupedBarPlot")
#'
#' # Change the vizSpecs
#' # viz_specs can get quite long, see
#' # https://crunch.io/api/reference/#post-/datasets/-dataset_id-/decks/-deck_id-/slides/
#' vizSpecs(slide) <- viz_specs
#'
#' # Change the query
#' #' query(slide) <- ~ cyl + wt
#' }
#nolint end
setGeneric("analyses", function(x) standardGeneric("analyses"))
#' @rdname analysis-methods
#' @export
setGeneric("analysis", function(x) standardGeneric("analysis"))
#' @rdname analysis-methods
#' @export
setGeneric("analysis<-", function(x, value) standardGeneric("analysis<-"))
#' @rdname analysis-methods
#' @export
setGeneric("query<-", function(x, value) standardGeneric("query<-"))
#' @rdname analysis-methods
#' @export
setGeneric("cube", function(x) standardGeneric("cube"))
#' @rdname analysis-methods
#' @export
setGeneric("cubes", function(x) standardGeneric("cubes"))
#' @rdname newMarkdownSlide
#' @export
setGeneric("slideMarkdown", function(x) standardGeneric("slideMarkdown"))
#' @rdname newMarkdownSlide
#' @export
setGeneric("slideMarkdown<-", function(x, value) standardGeneric("slideMarkdown<-"))
#' @rdname analysis-methods
#' @export
setGeneric("displaySettings", function(x) standardGeneric("displaySettings"))
#' @rdname analysis-methods
#' @export
setGeneric("displaySettings<-", function(x, value) standardGeneric("displaySettings<-"))
#' @rdname analysis-methods
#' @export
setGeneric("vizSpecs", function(x) standardGeneric("vizSpecs"))
#' @rdname analysis-methods
#' @export
setGeneric("vizSpecs<-", function(x, value) standardGeneric("vizSpecs<-"))
# Slide Catalog -----------------------------------------------------------
setMethod("initialize", "SlideCatalog", function(.Object, ...) {
.Object <- callNextMethod()
order <- crGET(.Object@orders$flat)
order <- unlist(order$graph)
.Object@index <- .Object@index[match(order, names(.Object@index))]
return(.Object)
})
#' @rdname describe-catalog
#' @export
setMethod("names", "SlideCatalog", function(x) titles(x))
#' @rdname describe-catalog
#' @export
setMethod("names<-", "SlideCatalog", function(x, value) titles(x) <- value)
#' @rdname deck-titles
#' @export
setMethod("titles", "SlideCatalog", function(x) getIndexSlot(x, "title"))
#' @rdname deck-titles
#' @export
setMethod("titles<-", "SlideCatalog", function(x, value) {
setIndexSlot(x, "title", value)
})
#' @rdname deck-titles
#' @export
setMethod("subtitles", "SlideCatalog", function(x) getIndexSlot(x, "subtitle"))
#' @rdname deck-titles
#' @export
setMethod("subtitles<-", "SlideCatalog", function(x, value) {
setIndexSlot(x, "subtitle", value)
})
#' @rdname crunch-extract
#' @export
setMethod("[[", "SlideCatalog", function(x, i, ...) {
getEntity(x, i, CrunchSlide)
})
#' @rdname crunch-extract
#' @export
setMethod(
"[[<-", c("SlideCatalog", "numeric", "missing", "CrunchSlide"),
function(x, i, j, value) {
if (length(i) > 1) {
# TODO, allow assignment of more than one slide
}
if (i > length(x) + 1) {
# TODO what to do with missing slide entries
i <- length(x) + 1
}
if (i <= length(x)) {
# we are replacing a slide, so return quickly modifying in place
out <- modifyCatalogInPlace(x, i, j, value)
return(out)
}
n_slides <- length(x)
payload <- value@body[c("title", "subtitle")]
anCat <- analyses(value)
payload$analyses <- lapply(seq_along(anCat), function(i) {
out <- anCat[[i]]
# TODO: Make sure API always sends all parts (and no legacy pre-viz_specs)
# and update fixtures
out <- out@body[
na.omit(match(
c("query", "query_environment", "display_settings", "transform", "viz_specs"),
names(out@body)
))
]
out
})
payload <- wrapEntity(body = payload)
crPOST(self(x), body = toJSON(payload))
if (i < n_slides) {
# You can't modify the contents of a slide by patching it
# so we need to add the new slide, delete the original slide,
# and reorder the slideCatalog.
# Is ^^^ really true?
new_order <- moveLastElement(seq_len(n_slides + 1), i)
reorderSlides(x, new_order)
with_consent(delete(x[[length(x)]]))
}
invisible(refresh(x))
}
)
#' Move and delete last element of a vector
#' This moves the last element of a vector to an index, then deletes the last
#' element, it is broken out for testing purposes
#'
#' @param v a vector
#' @param idx The index to move the last element to.
#'
#' @return a vector
#' @keywords internal
moveLastElement <- function(v, idx) {
v[idx] <- v[length(v)]
out <- v[1:(length(v) - 1)]
return(out)
}
#' Reorder slides in a CrunchDeck
#'
#' @param x A SlideCatalog
#' @param order The numeric order for slides to be reordered to.
#'
#' @return A SlideCatalog
reorderSlides <- function(x, order) {
url <- paste0(self(x), "flat")
payload <- crGET(url)
payload$graph <- payload$graph[order]
crPATCH(url, body = toJSON(payload))
return(refresh(x))
}
#' @rdname describe-catalog
#' @export
setMethod("types", "SlideCatalog", function(x) {
getIndexSlot(x, "type")
})
# CrunchSlide -------------------------------------------------------------------
# TODO: Find out what the mandatory display settings should be for the app then
# change this list to reflect those settings.
DEFAULT_DISPLAY_SETTINGS <- list(
percentageDirection = "colPct",
showEmpty = FALSE,
showMean = FALSE,
vizType = "table",
countsOrPercents = "percent",
decimalPlaces = 1L,
showSignif = TRUE,
currentTab = 0L
)
#' Append a new slide to a Crunch Deck
#'
#' @param deck A Crunch Deck
#' @param query A formula definition of a query to be used by the slide. See
#' Details of [`crtabs()`] for more information about making queries.
#' @param display_settings (optional) A list of display settings. If omitted,
#' slide will be a table of column percentages with hypothesis test highlighting
#' enabled. The most common setting used is `vizType`, which can be:
#' `table`, `groupedBarPlot`, `stackedBarPlot`, `horizontalBarPlot`,
#' `horizontalStackedBarPlot`, `donut`, and (if the second variable in the
#' query formula is a wave variable) `timeplot`.
#' In addition, `showValueLabels` (logical) controls whether the web app and
#' exports show labels on bars or arcs of donuts.
#' @param title The slide's title
#' @param subtitle The slide's subtitle
#' @param filter a `CrunchLogicalExpression`, a crunch `filter` object or
#' a vector of names of \code{\link{filters}} defined in the dataset (defaults
#' to `NULL`, using all data).
#' @param weight A weight variable (defaults to NULL, meaning no weight)
#' @param viz_specs Another set of options for the display of the slide, see
#' the [API documentation](
#' https://crunch.io/api/reference/#post-/datasets/-dataset_id-/decks/-deck_id-/slides/)
#' for more information.
#' @param transform A list of slide transformations, usually created using the function
#' [`makeDimTransform()`].
#' @param ... Further options to be passed on to the API
#'
#' @return CrunchSlide object
#' @seealso [`newMarkdownSlide`] for creating a markdown slide
#' @export
#'
#' @examples
#' \dontrun{
#' newSlide(
#' main_deck,
#' ~ cyl + wt,
#' title = "Cyl and Weight",
#' subtitle = "2017 Data"
#' )
#'
#' # Grouped bar plot
#' newSlide(
#' main_deck,
#' ~ approval + age4,
#' title = "Approval by age group",
#' display_settings = list(
#' vizType = "groupedBarPlot",
#' showValueLabels = TRUE
#' ),
#' subtitle = "2017 Data"
#' )
#'
#' # Horizontal stacked bars
#' newSlide(
#' main_deck,
#' ~ approval + age4,
#' title = "Approval by age group",
#' display_settings = list(
#' vizType = "horizontalStackedBarPlot"
#' ),
#' subtitle = "2017 Data"
#' )
#'
#' # A donut is only suitable for a single variable
#' newSlide(
#' main_deck,
#' ~ approval,
#' title = "Approval of new feature",
#' display_settings = list(
#' vizType = "donut",
#' showValueLabels = FALSE
#' ),
#' subtitle = "2017 Data"
#' )
#'
#' # A Grouped bar plot with slide transformations to hide a category
#' newSlide(
#' main_deck,
#' ~ approval + age4,
#' title = "Approval by age group",
#' display_settings = list(
#' vizType = "groupedBarPlot",
#' showValueLabels = TRUE
#' ),
#' transform = list(rows_dimension = makeDimTransform(hide = "Neutral")),
#' subtitle = "2017 Data"
#' )
#'
#' # Example of advanced options being set:
#' # viz_specs can get quite long, see
#' # https://crunch.io/api/reference/#post-/datasets/-dataset_id-/decks/-deck_id-/slides/
#' viz_specs <- list(
#' default = list(
#' format = list(
#' decimal_places = list(percentages = 0L, other = 2L),
#' show_empty = FALSE
#' )
#' ),
#' table = list(
#' measures = c("col_percent", "pairwise_t_test"),
#' page_layout = list(
#' rows = list(
#' top = list(),
#' bottom = c("base_unweighted", "scale_mean", "significant_columns")
#' ),
#' measure_layout = "long"
#' ),
#' pairwise_comparison = list(sig_threshold = c(0.05, 0.01)),
#' format = list(pval_colors = FALSE)
#' )
#' )
#'
#' newSlide(
#' main_deck,
#' ~categories(fav_array)+subvariables(fav_array),
#' display_settings = list(viz_type = list(value = "table")),
#' title = "custom slide",
#' filter = filters(ds)[[1]],
#' weight = ds$weight,
#' viz_specs = viz_specs
#' )
#'
#' # Can also specify `analyses` directly, which allows for very advanced use.
#' # `formulaToSlideQuery()` and `slideQueryEnv()` help describe the API
#' newSlide(
#' main_deck,
#' title = "custom slide",
#' analyses = list(list(
#' query = formulaToSlideQuery(~categories(fav_array)+subvariables(fav_array), ds),
#' query_environment = slideQueryEnv(filter = filters(ds)[[1]]),
#' display_settings = list(viz_type = list(value = "table")),
#' viz_specs = viz_specs
#' ))
#' )
#' }
newSlide <- function(
deck,
query = NULL,
display_settings = list(),
title = "",
subtitle = "",
filter = NULL,
weight = NULL,
viz_specs = NULL,
transform = NULL,
...
) {
stopifnot(inherits(query, "formula") || is.null(query))
settings <- modifyList(DEFAULT_DISPLAY_SETTINGS, display_settings)
settings <- wrapDisplaySettings(settings)
ds <- loadDataset(datasetReference(deck))
filter <- standardize_tabbook_filter(ds, filter)
payload <- list(title = title, subtitle = subtitle, ...)
check_newslide_args(
query, display_settings, payload, filter, weight, viz_specs, transform
)
if (any(dimTransformNeedsPrep(transform))) {
transform <- prepareDimTransforms(transform, query, ds) #nolint
}
if (!is.null(query)) {
query <- formulaToCubeQuery(query, ds)
validateSlideQuery(query)
analysis <- list(
query = query,
display_settings = settings
)
query_environment <- list()
if (!is.null(filter)) query_environment$filter <- filter
if (!is.null(weight)) {
query_environment$weight <- self(weight)
# Also add to the query to match webapp behavior
analysis$query$weight <- self(weight)
}
if (length(query_environment) > 0) analysis$query_environment <- query_environment
if (!is.null(viz_specs)) {
analysis$viz_specs <- viz_specs
}
if (!is.null(transform)) analysis$transform <- transform
payload[["analyses"]] <- list(analysis)
}
payload <- wrapEntity(body = payload)
url <- crPOST(shojiURL(deck, "catalogs", "slides"), body = toJSON(payload))
return(CrunchSlide(crGET(url)))
}
#nolint start
check_newslide_args <- function(
query, display_settings, payload, filter, weight, viz_specs, transform
) {
has_analyses <- "analyses" %in% names(payload)
has_any_analysis_objects <- length(display_settings) != 0 ||
!is.null(filter) ||
!is.null(weight) ||
!is.null(viz_specs) ||
!is.null(transform)
if (has_analyses && !is.null(query)) {
halt("Cannot specify both a `query` and `analyses` for `newSlide()`")
}
if (!has_analyses && is.null(query)) {
halt("Must specify either a `query` or `analyses` for `newSlide()`")
}
if (has_analyses && has_any_analysis_objects) {
warning(paste0(
"`display_settings`, `filter`, `weight`, `viz_specs` and `transform` are ",
"ignored if `analyses` are defined directly for `newSlide()`"
))
}
}
#nolint end
validateSlideQuery <- function(query) {
dimensions <- query$dimensions
if (length(dimensions) < 3) return()
is_subvar_dim <- vapply(dimensions, function(x) {
"function" %in% names(x) &&
x[["function"]] == "dimension" &&
"args" %in% names(x) &&
identical(x[["args"]][[2]], zcl("subvariables"))
}, logical(1))
if (!any(is_subvar_dim)) return()
subvar_args <- lapply(which(is_subvar_dim), function(x) dimensions[[x]][["args"]][[1]])
first_dim_is_array_cat <- vapply(subvar_args, function(x) {
identical(dimensions[[1]], x) ||
identical(dimensions[[1]], zfunc("dimension", x, "categories"))
}, logical(1))
if (any(first_dim_is_array_cat)) {
halt(
"First dimension of 3+ dimension cube for slide analysis cannot be an array's",
"categories. You probably want to use `selectCategories()` to collapse the",
"categorical array's categories dimension."
)
}
}
#' @rdname crunch-extract
#' @export
setMethod("[[", "CrunchAnalysisSlide", function(x, i, ...) {
an_cat <- analyses(x)
return(an_cat[[i]])
})
#' @rdname crunch-extract
#' @export
setMethod("[[<-", "CrunchAnalysisSlide", function(x, i, j, value) {
an_cat <- analyses(x)
an_cat[[i]] <- value
invisible(refresh(x))
})
#' @rdname deck-titles
#' @export
setMethod("title", "CrunchSlide", function(x) {
return(x@body$title)
})
#' @rdname deck-titles
#' @export
setMethod("title<-", "CrunchSlide", function(x, value) {
setEntitySlot(x, "title", value)
})
#' @rdname deck-titles
#' @export
setMethod("subtitle", "CrunchSlide", function(x) {
return(x@body$subtitle)
})
#' @rdname deck-titles
#' @export
setMethod("subtitle<-", "CrunchSlide", function(x, value) {
setEntitySlot(x, "subtitle", value)
})
#' @rdname analysis-methods
#' @export
setMethod("type", "CrunchSlide", function(x) {
return(x@body$type)
})
#' @rdname analysis-methods
#' @export
setMethod("analyses", "CrunchAnalysisSlide", function(x) {
AnalysisCatalog(crGET(shojiURL(x, "catalogs", "analyses")))
})
#' @rdname analysis-methods
#' @export
setMethod("analysis", "CrunchAnalysisSlide", function(x) {
out <- AnalysisCatalog(crGET(shojiURL(x, "catalogs", "analyses")))
return(out[[1]])
})
#' @rdname analysis-methods
#' @export
setMethod("analysis<-", c("CrunchAnalysisSlide", "formula"), function(x, value) {
analysis <- analyses(x)[[1]]
query(analysis) <- value
return(invisible(x))
})
#' @rdname analysis-methods
#' @export
setMethod("analysis<-", c("CrunchAnalysisSlide", "Analysis"), function(x, value) {
analysis_cat <- analyses(x)
return(invisible(modifyCatalogInPlace(analysis_cat, 1, NULL, value)))
})
#' @rdname analysis-methods
#' @export
setMethod("analysis<-", c("CrunchAnalysisSlide", "list"), function(x, value) {
payload <- wrapEntity(body = value)
url <- self(analysis(x))
crPATCH(url, body = toJSON(payload))
invisible(refresh(x))
})
#' @rdname analysis-methods
#' @export
setMethod("filter", "CrunchAnalysisSlide", function(x, ...) {
deprecate_filter("CrunchSlide")
})
#' @rdname analysis-methods
#' @export
setMethod("filters", "CrunchAnalysisSlide", function(x) {
analysis <- analyses(x)[[1]]
return(filters(analysis))
})
#' @rdname analysis-methods
#' @export
setMethod("filters<-", c("CrunchAnalysisSlide", "ANY"), function(x, value) {
# check that there is only on analysis?
first_analysis <- analyses(x)[[1]]
filters(first_analysis) <- value
return(invisible(x))
})
#' @rdname analysis-methods
#' @export
setMethod("query<-", "CrunchAnalysisSlide", function(x, value) {
analysis <- analyses(x)[[1]]
query(analysis) <- value
return(invisible(x))
})
#' @rdname analysis-methods
#' @export
setMethod("cubes", "CrunchAnalysisSlide", function(x) cubes(analyses(x)))
#' @rdname analysis-methods
#' @export
setMethod("cube", "CrunchAnalysisSlide", function(x) cube(analyses(x)[[1]]))
#' @rdname analysis-methods
#' @export
setMethod("displaySettings", "CrunchAnalysisSlide", function(x) displaySettings(analyses(x)))
#' @rdname analysis-methods
#' @export
setMethod("displaySettings<-", "CrunchAnalysisSlide", function(x, value) {
an_cat <- analyses(x)
displaySettings(an_cat) <- value
return(invisible(x))
})
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs", "CrunchAnalysisSlide", function(x) vizSpecs(analyses(x)))
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs<-", "CrunchAnalysisSlide", function(x, value) {
an_cat <- analyses(x)
vizSpecs(an_cat) <- value
return(invisible(x))
})
# AnalysisCatalog --------------------------------------------------------------
setMethod("initialize", "AnalysisCatalog", function(.Object, ...) {
.Object <- callNextMethod()
if (length(.Object@index) > 1) {
order <- crGET(.Object@orders$order)
order <- unlist(order$graph)
.Object@index <- .Object@index[match(order, names(.Object@index))]
}
return(.Object)
})
#' @rdname crunch-extract
#' @export
setMethod("[[", "AnalysisCatalog", function(x, i, ...) {
getEntity(x, i, Analysis)
})
#' @rdname crunch-extract
#' @export
setMethod(
"[[<-", c("AnalysisCatalog", "numeric", "missing", "formula"),
function(x, i, j, value) {
if (i > length(x)) {
halt(
"Index out of bounds, you can only assign a formula to an ",
"existing analysis."
)
}
analysis <- x[[i]]
query(analysis) <- value
invisible(refresh(x))
}
)
#' @rdname crunch-extract
#' @export
setMethod(
"[[<-", c("AnalysisCatalog", "numeric", "missing", "Analysis"),
function(x, i, j, value) {
if (length(i) > 1) {
# TODO, recurse through i
}
if (i > length(x) + 1) {
# TODO what to do with adding an analysis that's not the next one.
}
# TODO: Make sure API always sends all parts (and no legacy pre-viz_specs)
# and update fixtures
payload <- value@body[
na.omit(match(
c("query", "display_settings", "query_environment", "viz_specs", "transform"),
names(value@body)
))
]
payload <- wrapEntity(body = payload)
if (i <= length(x)) {
url <- names(x@index)[i]
crPATCH(url, body = toJSON(payload))
} else {
crPOST(self(x), body = toJSON(payload))
}
invisible(refresh(x))
}
)
#' @rdname crunch-extract
#' @export
setMethod(
"[[<-", c("AnalysisCatalog", "numeric", "missing", "list"),
function(x, i, j, value) {
all_fmla <- vapply(value, function(x) inherits(x, "formula"), logical(1))
if (any(!all_fmla)) {
halt("Entry ", which(!all_fmla), " is not a formula")
}
if (length(i) != length(value)) {
noun <- if (length(i) == 1) " analysis." else " analyses."
halt(
"Invalid assignment. You tried to assign ", length(value),
" formulas to ", length(i), noun
)
}
mapply(function(analysis, fmla) {
analysis <- fmla
}, analysis = x[[i]], fmla = value)
}
)
#' @rdname analysis-methods
#' @export
setMethod("cubes", "AnalysisCatalog", function(x) {
lapply(seq_along(x@index), function(i) cube(x[[i]]))
})
#' @rdname analysis-methods
#' @export
setMethod("displaySettings", "AnalysisCatalog", function(x) {
settings_list <- lapply(seq_along(x), function(i) {
displaySettings(x[[i]])
})
if (length(settings_list) == 1) {
return(settings_list[[1]])
} else {
return(settings_list)
}
})
#' @rdname analysis-methods
#' @export
setMethod("displaySettings<-", c("AnalysisCatalog", "list"), function(x, value) {
analyses <- lapply(seq_along(x), function(i) x[[i]])
lapply(analyses, function(x) displaySettings(x) <- value)
})
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs", "AnalysisCatalog", function(x) {
settings_list <- lapply(seq_along(x), function(i) {
vizSpecs(x[[i]])
})
if (length(settings_list) == 1) {
return(settings_list[[1]])
} else {
return(settings_list)
}
})
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs<-", c("AnalysisCatalog", "list"), function(x, value) {
analyses <- lapply(seq_along(x), function(i) x[[i]])
lapply(analyses, function(x) vizSpecs(x) <- value)
})
# Analysis ----------------------------------------------------------------
#' @rdname analysis-methods
#' @export
setMethod("query<-", c("Analysis", "formula"), function(x, value) {
ds <- loadDataset(datasetReference(x))
payload <- list(query = formulaToCubeQuery(value, data = ds))
payload <- wrapEntity(body = payload)
crPATCH(self(x), body = toJSON(payload))
return(invisible(refresh(x)))
})
#' @rdname analysis-methods
#' @export
formulaToSlideQuery <- function(query, dataset) {
formulaToCubeQuery(query, dataset)
}
#' @rdname analysis-methods
#' @export
setMethod("cube", "Analysis", function(x) {
# Always use the weight from the query_environment (even if missing in qe, we want to
# override with no weight in this case)
cube_query <- x@body$query
cube_query$weight <- NULL
# Actually want weight=NULL to override the default dataset weight
cube_query <- c(cube_query, list(weight = x@body$query_environment$weight))
http_query <- list(query = toJSON(cube_query, for_query_string = TRUE))
# Don't pass filter=NULL because API's probably grumpy about that. Also, rather than pass a
# list of filters if there are multiple, the API expects multiple `filter=` URL query
# parameters
qe_filters <- x@body$query_environment$filter
if (length(qe_filters) > 0) {
qe_filters <- lapply(qe_filters, function(filt) toJSON(filt, for_query_string = TRUE))
names(qe_filters) <- rep("filter", length(qe_filters))
http_query <- c(http_query, qe_filters)
}
CrunchCube(crGET(
cubeURL(x),
query = http_query
))
})
#' @rdname analysis-methods
#' @export
setMethod("displaySettings", "Analysis", function(x) {
lapply(x@body$display_settings, function(x) x$value)
})
#' @rdname analysis-methods
#' @export
setMethod("displaySettings<-", "Analysis", function(x, value) {
settings <- modifyList(displaySettings(x), value)
settings <- wrapDisplaySettings(settings)
payload <- list(display_settings = settings)
payload <- wrapEntity(body = payload)
crPATCH(self(x), body = toJSON(payload))
invisible(refresh(x))
})
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs", "Analysis", function(x) {
x@body$viz_specs
})
#' @rdname analysis-methods
#' @export
setMethod("vizSpecs<-", "Analysis", function(x, value) {
payload <- wrapEntity(body = list(viz_specs = value))
crPATCH(self(x), body = toJSON(payload))
invisible(refresh(x))
})
# This processes a names list of display setting values to the form that is
# required by the API.
wrapDisplaySettings <- function(settings) {
return(lapply(settings, function(x) list(value = x)))
}
#' @rdname analysis-methods
#' @export
setMethod("filter", "Analysis", function(x, ...) {
deprecate_filter("Analysis")
})
#' @rdname analysis-methods
#' @export
setMethod("filters", "Analysis", function(x) {
filters <- x@body$query_environment$filter
.filtersFromSlide(filters, ds_ref = datasetReference(x))
})
.filtersFromSlide <- function(filters, ds_ref) {
if (length(filters) == 0) {
return(NULL)
}
# jsonlite unboxes a single filter so it's no longer a list of lists
# but to make code more consistent, we add it back.
if (!is.null(names(filters))) {
filters <- list(filters)
}
lapply(filters, function(filt) {
if ("filter" %in% names(filt)) {
CrunchFilter(crGET(filt$filter))
} else {
# an adhoc filter
adhoc_expr <- CrunchLogicalExpr(
expression = idsToURLs(
# 02/2021: Not sure if this is still needed anymore, server doesn't
# currently seem to be sending the `dataset` attributes this takes out.
# But mocks require it (/4/decks/8ad8/slides/72e8/analysies/52fb.json)
fixAdhocFilterExpression(filt),
paste0(ds_ref, "/variables/")
),
dataset_url = ds_ref
)
adhoc_expr
}
})
}
#' @rdname analysis-methods
#' @export
setMethod("filter", "ANY", function(x, ...) {
for (searchpath in search()) {
func <- get("filter", as.environment(searchpath))
if (!identical(func, crunch::filter)) {
return(func(x, ...))
}
}
halt("No method found for filter for object of type ", dQuote(methods::getClass(x))) # nocov
})
#' @rdname analysis-methods
#' @export
setMethod("filter<-", "CrunchAnalysisSlide", function(x, value) {
deprecate_filter("Analysis", arrow = TRUE)
})
#' @rdname analysis-methods
#' @export
setMethod("filter<-", "Analysis", function(x, value) {
deprecate_filter("Analysis", arrow = TRUE)
})
#' @rdname analysis-methods
#' @export
setMethod("filters<-", c("Analysis", "CrunchLogicalExpr"), function(x, value) {
return(set_analysis_filter_or_weight(x, filter = list(value@expression)))
})
#' @rdname analysis-methods
#' @export
setMethod("filters<-", c("Analysis", "CrunchFilter"), function(x, value) {
# crPATCH(self(x), body = toJSON(frmt))
return(set_analysis_filter_or_weight(x, filter = standardize_filter_list(value)))
})
#' @rdname analysis-methods
#' @export
setMethod("filters<-", c("Analysis", "NULL"), function(x, value) {
# crPATCH(self(x), body = toJSON(frmt))
return(set_analysis_filter_or_weight(x, filter = list()))
})
#' @rdname analysis-methods
#' @export
setMethod("filters<-", c("Analysis", "list"), function(x, value) {
filter <- standardize_filter_list(value)
return(set_analysis_filter_or_weight(x, filter = filter))
})
#' @rdname analysis-methods
#' @export
slideQueryEnv <- function(weight, filter) {
if (missing(weight) && missing(filter)) {
halt("Must specify at least one of `weight` or `filter`")
}
out <- list()
if (!missing(weight)) {
out$weight <- if (is.null(weight)) list() else self(weight)
}
if (!missing(filter)) {
if (is.null(filter)) {
out$filter <- list()
} else if (is.CrunchExpr(filter)) {
out$filter <- list(filter@expression)
} else {
out$filter <- list(self(filter))
}
}
out
}
#' @rdname analysis-methods
#' @export
setMethod("cubes", "CrunchDeck", function(x) {
slide_types <- types(x)
out <- lapply(seq_len(length(x)), function(i) {
if (slide_types[i] != "analysis") return(NULL) # Markdown slides don't have cubes
cubes <- cubes(x[[i]])
# If a slide has several analyses we should return a sublist of
# cubes, but most of the time they will have one analysis so not
# including the sublist is preferable.
if (length(cubes) == 1) {
cubes <- cubes[[1]]
}
return(cubes)
})
names(out) <- titles(x)
return(out)
})
#' @rdname analysis-methods
#' @export
setMethod("weight", "CrunchAnalysisSlide", function(x) {
analysis <- analyses(x)[[1]]
return(weight(analysis))
})
#' @rdname analysis-methods
#' @export
setMethod("weight<-", c("CrunchAnalysisSlide", "ANY"), function(x, value) {
# check that there is only on analysis?
first_analysis <- analyses(x)[[1]]
weight(first_analysis) <- value
return(invisible(x))
})
#' @rdname analysis-methods
#' @export
setMethod("weight", "Analysis", function(x) {
wt <- x@body$query_environment$weight
if (length(wt) == 0) {
return(NULL)
}
full_ds <- loadDataset(datasetReference(VariableEntity(x)))
wt_pos <- which(urls(allVariables(full_ds)) == wt)
filt <- filters(x)
if (inherits(filt, "CrunchFilter")) {
filt <- CrunchLogicalExpr(
dataset_url = self(full_ds),
expression = filt@body[["expression"]]
)
}
CrunchVariable(allVariables(full_ds)[[wt_pos]], filter = filt)
})
#' @rdname weight
#' @export
setMethod("weight<-", c("Analysis", "CrunchVariable"), function(x, value) {
if (!is.weightVariable(value)) halt(paste0(
"Variable '", alias(value), "' is not a weightVariable"
))
return(set_analysis_filter_or_weight(x, weight = self(value)))
})
#' @rdname weight
#' @export
setMethod("weight<-", c("Analysis", "NULL"), function(x, value) {
return(set_analysis_filter_or_weight(x, weight = NULL))
})
# TODO: setMethod("weight<-", c("Analysis", "CrunchVariable") method to use alias?
# Want to update filter/weight components separately so that we don't
# remove something accidentally.
set_analysis_filter_or_weight <- function(x, filter, weight) {
query_env <- slot(x, "body")[["query_environment"]]
# The single "[" <- list() notation allows NULLs in weight rather than just removing weight
if (!missing(filter) && is.null(filter)) filter <- list()
if (!missing(filter)) query_env["filter"] <- list(filter)
if (!missing(weight)) query_env["weight"] <- list(weight)
# Also need to set weight in the query to match webapp's behavior
if (!missing(weight)) {
query <- slot(x, "body")[["query"]]
query$weight <- weight
setMultiEntitySlots(x, query_environment = query_env, query = query)
} else { # But if only updating filter, then leave query alone
setEntitySlot(x, "query_environment", query_env)
}
}
# Markdown ---------------------------------------------------------------
#' Add a new markdown slide to a deck
#'
#' Markdown slides allow you to add rich text tiles to your Crunch Dashboards.
#' `markdownSlideImage()` is a helper for embedding the data of an image from
#' your computer into the slide.
#'
#' @inheritParams newSlide
#' @param ... Unnamed arguments are text that are combined to create the markdown body
#' named arguments are passed to the API.
#' @return A `MarkdownCrunchSlide`
#' @export
#'
#' @seealso [`newSlide()`] for creating an analysis slide
#' @examples
#' \dontrun{
#' newMarkdownSlide(deck, "We contacted 1,000 people by telephone", title = "Methodology")
#'
#' newMarkdownSlide(
#' deck,
#' "The 3 most **popular** vegetables are:\n",
#' "- Fennel\n",
#' "- Carrots\n",
#' "- Avocado\n",
#' title = "Key findings"
#' )
#'
#' newMarkdownSlide(
#' deck,
#' "crunch.io: ",
#' markdownSlideImage("logo.png")
#' )
#' }
newMarkdownSlide <- function(deck, ..., title = "", subtitle = "") {
# Separate out unnamed dots (markdown body) from named dots (passed to API)
dots <- list(...)
if (is.null(names(dots))) {
named_dots <- NULL
unnamed_dots <- dots
} else {
have_names <- names(dots) != "" & !is.na(names(dots))
named_dots <- dots[have_names]
unnamed_dots <- dots[!have_names]
}
markdown <- paste0(unnamed_dots, collapse = "")
body <- c(
list(type = "markdown", markdown = markdown, title = title, subtitle = subtitle),
named_dots # not actually used yet, but allowed for future expansion
)
payload <- wrapEntity(body = body)
url <- crPOST(shojiURL(deck, "catalogs", "slides"), body = toJSON(payload))
return(CrunchSlide(crGET(url)))
}
#' @rdname newMarkdownSlide
#' @param file File path to an image
#' @export
markdownSlideImage <- function(file) {
if (!file.exists(file)) halt("Could not find file: ", file)
paste0(
"![", basename(file), "]",
"(", base64enc::dataURI(file = file, mime = mime::guess_type(file)), ")"
)
}
#' @rdname newMarkdownSlide
#' @param x A `CrunchMarkdownSlide`
#' @export
setMethod("slideMarkdown", c("CrunchMarkdownSlide"), function(x) {
x@body$markdown
})
#' @rdname newMarkdownSlide
#' @param value A string to replace the markdown content with
#' @export
setMethod("slideMarkdown<-", c("CrunchMarkdownSlide", "character"), function(x, value) {
setEntitySlot(x, "markdown", value)
})
deprecate_filter <- function(type, arrow = FALSE) {
arrow <- if (arrow) "<-" else ""
msg <- paste0(
"`filter", "()", arrow, "` is no longer supported on ", type, ". Use ",
"`filter", crayon::bold(crayon::underline("s")), "()", arrow, "` instead."
)
halt(msg)
}
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.