R/multitables.R

In crunch: Crunch.io Data Tools

setMethod("initialize", "MultitableCatalog", init.sortCatalog)

#' Multitable entities for a dataset
#'
#' @param x a CrunchDataset
#' @param value for the assignment method, a MultitableCatalog
#' @return an object of class MultitableCatalog containing references to
#' Multitable entities. (Setter returns the Dataset.)
#' @name multitable-catalog
#' @aliases multitables multitables<-
NULL

#' @rdname multitable-catalog
#' @export
setMethod("multitables", "CrunchDataset", function(x) {
    MultitableCatalog(crGET(shojiURL(x, "catalogs", "multitables")))
})

#' @rdname multitable-catalog
#' @export
setMethod("multitables<-", "CrunchDataset", function(x, value) x)

#' @rdname crunch-extract
#' @export
setMethod("[[", c("MultitableCatalog", "numeric"), function(x, i, ...) {
    getEntity(x, i, Multitable, ...)
})

#' @rdname crunch-extract
#' @export
setMethod(
    "[[<-", c("MultitableCatalog", "character", "missing", "formula"),
    function(x, i, j, value) {
        stopifnot(length(i) == 1)
        w <- match(i, names(x))
        ## Creating a new filter if there are no matching names
        if (is.na(w)) {
            f <- newMultitable(
                formula = value,
                data = loadDataset(datasetReference(x)),
                name = i
            )
            return(refresh(x))
        }
        callNextMethod(x, w, value = value)
    }
)

#' @rdname crunch-extract
#' @export
setMethod(
    "[[<-", c("MultitableCatalog", "numeric", "missing", "formula"),
    function(x, i, j, value) {
        stopifnot(length(i) == 1)

        ds <- loadDataset(datasetReference(x))
        template <- formulaToQuery(value, data = ds)

        if (i %in% seq_along(urls(x))) {
            payload <- makeMultitablePayload(template = template)
            crPATCH(urls(x)[i], body = toJSON(payload))
            return(x)
        } else {
            halt("subscript out of bounds: ", i)
        }
    }
)

#' @rdname crunch-extract
#' @export
setMethod(
    "[[<-", c("MultitableCatalog", "ANY", "missing", "Multitable"),
    modifyCatalogInPlace
)

makeMultitablePayload <- function(template, ...) {
    template <- lapply(template$dimensions, function(x) list(query = x))

    return(wrapEntity(template = template, ...))
}

#' @rdname crunch-extract
#' @export
setMethod(
    "[[<-", c("MultitableCatalog", "ANY", "missing", "NULL"),
    function(x, i, j, value) {
        stopifnot(length(i) == 1)
        if (is.character(i) && !i %in% names(x)) {
            return()
        } else if (is.numeric(i) && !i %in% seq_along(urls(x))) {
            return()
        }
        delete(x[[i]])
        invisible(NULL)
    }
)

#' @rdname describe-entity
#' @export
setMethod("name<-", "Multitable", function(x, value) {
    setEntitySlot(x, "name", value)
})

#' @export
#' @rdname describe-catalog
setMethod("names<-", "MultitableCatalog", function(x, value) {
    setIndexSlotOnEntity(x, "name", value)
})


#' Create a new Multitable
#'
#' Multitables, or "banners" or "crossbreaks", define a set of variables or
#' or query expressions to crosstab with as a unit. They are used in the Crunch
#' web app to display tables side by side, as well as to define one dimension
#' of a tab book.
#' @param formula an object of class 'formula' object with the
#' cross-classifying variables separated by '+' on the right-hand side.
#' Following how [stats::formula()] works in R, it should start
#' with "~". Variables on left-hand side of the formula have no meaning in this
#' function.
#' @param data an object of class `CrunchDataset` in which to create the
#' multitable, and to which the variables referenced in `formula` belong.
#' @param name character name to give the new multitable object. If omitted,
#' a default name will be derived from `formula`.
#' @param ... Additional multitable attributes to set. Options include
#' `is_public`.
#' @return An object of class `Multitable`
#' @seealso [`stats::formula`]
#' @examples
#' \dontrun{
#' m <- newMultitable(~ gender + age4 + marstat, data = ds)
#' name(m) # [1] "gender + age4 + marstat"
#' }
#' @export
newMultitable <- function(formula, data, name, ...) {
    ## Validate inputs
    if (missing(formula)) {
        halt("Must provide a formula")
    }
    if (missing(data) || !is.dataset(data)) {
        halt(dQuote("data"), " must be a Dataset")
    }

    template <- formulaToQuery(formula, data)
    if (missing(name)) {
        name <- RHS_string(formula)
    }

    payload <- makeMultitablePayload(template = template, name = name, ...)
    u <- crPOST(shojiURL(data, "catalogs", "multitables"),
        body = toJSON(payload)
    )

    invisible(Multitable(crGET(u)))
}