R/shoji-folder.R

In Crunch-io/rcrunch: Crunch.io Data Tools

setMethod("initialize", "ShojiFolder", function(.Object, ...) {
    .Object <- callNextMethod(.Object, ...)
    .Object@graph <- lapply(.Object@graph, absoluteURL, .Object@self)
    if (length(.Object@graph)) {
        # Root catalogs may not have a graph (right?)
        .Object@index <- .Object@index[unlist(.Object@graph)]
    }
    return(.Object)
})

is.folder <- function(x) inherits(x, "ShojiFolder")

#' @export
#' @rdname describe-catalog
setMethod("types", "ShojiFolder", function(x) getIndexSlot(x, "type"))

#' @rdname crunch-extract
#' @export
setMethod("[[", c("ShojiFolder", "numeric"), function(x, i, ..., drop = FALSE) {
    out <- index(x)[i]
    if (is.null(out[[1]])) {
        return(NULL)
    }
    return(folderExtraction(x, out))
})

#' @rdname crunch-extract
#' @export
setMethod("[[", c("ShojiFolder", "character"), function(x, i, ..., drop = FALSE) {
    path <- parseFolderPath(i)
    if (nchar(path[1]) == 0) {
        ## Go to root level
        x <- rootFolder(x)
        path <- path[-1]
    } else if (identical(path[1], "~")) {
        ## Go to personal
        x <- personalFolder(x)
        path <- path[-1]
    }
    create <- isTRUE(list(...)$create)
    while (length(path)) {
        ## Recurse
        segment <- path[1]
        if (segment == ".") {
            ## We're already here
            this <- x
        } else if (segment == "..") {
            ## Go up a level
            this <- folder(x)
            if (is.null(this)) {
                halt(deparse(i), " is an invalid path")
            }
        } else {
            this <- x[[whichCatalogEntry(x, segment)]]
            if (is.null(this) && create) {
                u <- createFolder(x, segment)
                this <- new(class(x), crGET(u))
            } else if (!is.folder(this) && length(path) > 1) {
                ## Can't recurse deeper if this isn't a folder
                halt(deparse(i), " is an invalid path: ", segment, " is not a folder")
            }
        }
        path <- path[-1]
        x <- this
    }
    return(x)
})

parseFolderPath <- function(path) {
    ## path can be "/" separated, and can change that delimiter with
    ## options(crunch.delimiter="|") or something in case you have real "/"
    if (length(path) == 1) {
        path <- unlist(strsplit(path, folderDelimiter(), fixed = TRUE))
    }
    return(path)
}

folderDelimiter <- function() envOrOption("crunch.delimiter", "/")

parentFolderURL <- function(x) {
    if (is.variable(x) || inherits(x, "VariableFolder")) {
        shojiURL(x, "catalogs", "folder", mustWork = FALSE)
    } else {
        # A dataset or project
        shojiURL(x, "catalogs", "project", mustWork = FALSE)
    }
}

walkFoldersToRoot <- function(x) {
    ## Walk the path up through the parents until you can go no farther
    this <- folder(x)
    ## If the parent of x is NULL, we're already at top level.
    while (!is.null(this)) {
        x <- this
        this <- folder(x)
    }
    return(x)
}

setMethod("rootFolder", "ShojiFolder", walkFoldersToRoot)

createFolder <- function(where, name, index, ...) {
    ## TODO: include index of variables/folders in a single request;
    ## turn index into index + graph in payload
    ## TODO: also for reordering, function that takes a list (index) and returns
    ## list(index=index, graph=names(index))
    if (inherits(where, "VariableFolder")) {
        bod <- wrapCatalog(body = list(name = name, ...))
    } else {
        ## Special case: projects strictly require "entity"
        ## Remove after https://www.pivotaltracker.com/story/show/160328444
        bod <- wrapEntity(body = list(name = name, ...))
    }
    crPOST(self(where), body = toJSON(bod))
}

#' Change the order of entities in folder
#'
#' @param folder A `VariableFolder` or other `*Folder` object
#' @param ord A vector of integer indices or character references to objects
#' contained in the folder
#' @return `folder` with the order dictated by `ord`. The function also persists
#' that order on the server.
#' @export
setOrder <- function(folder, ord) {
    # If ord is character, match against names/aliases/urls
    if (is.character(ord)) {
        nums <- whichCatalogEntry(folder, ord)
        # Validate that none are NA
        bads <- is.na(nums)
        if (any(bads)) {
            halt(
                ifelse(sum(bads) > 1, "Invalid values: ", "Invalid value: "),
                paste(ord[bads], collapse = ", ")
            )
        }
        ord <- nums
    }
    if (!is.numeric(ord)) {
        halt("Order values must be character or numeric, not ", class(ord))
    }
    # Allow for omitted values, and validate
    valid <- seq_len(length(folder))
    bad <- setdiff(ord, valid)
    if (length(bad)) {
        halt(
            ifelse(length(bad) > 1, "Invalid values: ", "Invalid value: "),
            paste(bad, collapse = ", ")
        )
    }
    dupes <- duplicated(ord)
    if (any(dupes)) {
        halt(
            "Order values must be unique: ",
            paste(unique(ord[dupes]), collapse = ", "),
            ifelse(sum(dupes) > 1, " are", " is"), " duplicated"
        )
    }
    ord <- c(ord, setdiff(valid, ord))
    # Only send an update if there's a change
    if (!all(ord == valid)) {
        # Update folder in place
        index(folder) <- index(folder)[ord]
        folder@graph <- as.list(urls(folder))
        # PATCH graph
        crPATCH(self(folder), body = toJSON(wrapCatalog(graph = urls(folder))))
    }
    return(folder)
}

path <- function(x) {
    out <- name(x)
    parent <- folder(x)
    ## If the parent of x is NULL, we're already at top level.
    while (!is.null(parent)) {
        out <- c(name(parent) %||% "", out)
        parent <- folder(parent)
    }
    out <- paste(out, collapse = folderDelimiter())
    if (nchar(out) == 0) {
        ## Root
        out <- folderDelimiter()
    }
    return(out)
}

# setMethod("folderExtraction", "ShojiFolder", function (x, tuple) {
#     ## Default method: return a folder of the same type
#     return(get(class(x))(crGET(names(tuple))))
# })

setMethod("personalFolder", "ShojiFolder", function(x) {
    halt("Not implemented")
})