Nothing
.updateVariable <- function(variable, value, filter = NULL) {
## if the value is an expression, check that the value is not a derivation,
## those can be dangerous if they change the variable type.
## only needed until https://www.pivotaltracker.com/story/show/154982045 is
## resolved
if (is.Expr(value)) {
castFuncs <- c(
"cast", "format_datetime", "parse_datetime",
"numeric_to_datetime", "datetime_to_numeric"
)
if (has.function(value@expression, castFuncs)) {
halt(
"A variable cannot be updated with a derivation that changes ",
"its type. Are you trying to overwrite a variable with a ",
"derivation of itself to change the type? If so, you might ",
"want to use `type(ds$variable)<-` instead."
)
}
}
## Construct a ZCL update payload, then POST it
payload <- list(
command = "update",
variables = .updatePayload(variable, value)
)
payload[["filter"]] <- zcl(filter)
dref <- datasetReference(variable)
update_url <- paste0(dref, "table/")
out <- crPOST(update_url, body = toJSON(payload))
dropCache(dref)
invisible(out)
}
.updatePayload <- function(variable, value) {
## Construct the "variables" key of a ZCL update payload
if (is.Array(variable)) {
out <- sapply(urls(subvariables(variable)), function(x) {
zcl(value)
}, simplify = FALSE)
} else {
out <- structure(list(zcl(value)),
.Names = self(variable)
)
}
## Check for missingness and replace the NAs with special values
out <- lapply(out, function(x) {
if ("column" %in% names(x)) {
missings <- is.na(x$column)
if (any(missings)) {
x$column <- as.list(x$column)
x$column[missings] <- rep(
list(.no.data.value(type(variable))), sum(missings)
)
}
}
return(x)
})
return(out)
}
.dispatchFilter <- function(f) {
## Given a valid R index (numeric, logical) or CrunchExp, make a ZCL (?) filter
## TODO: f <- zcl(f) ?
if (is.logical(f)) {
## TODO: Validate
## TODO: send 0/1
# f <- as.integer(f)
# And what about NA? set as 0? set to -1? let downstream set to -1?
f <- which(f)
} # TODO: if 0/1, else if
if (is.numeric(f)) {
## TODO: Validate
f <- .seqCrunch(zfunc("row"), f - 1)
}
return(f)
}
#' @rdname crunch-extract
#' @export
setMethod("[<-", c("CrunchVariable", "ANY", "missing", "ANY"), .backstopUpdate)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CrunchVariable", "ANY", "missing", "NULL"),
function(x, i, j, value) return(NULL)
)
.var.updater <- function(x, i, j, value) {
if (missing(i)) i <- NULL
.updateVariable(x, value, filter = .dispatchFilter(i))
return(x)
}
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("TextVariable", "ANY", "missing", "character"),
.var.updater
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("NumericVariable", "ANY", "missing", "numeric"),
.var.updater
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("DatetimeVariable", "ANY", "missing", "Date"),
.var.updater
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("DatetimeVariable", "ANY", "missing", "POSIXt"),
.var.updater
)
.var.updater.crunchobj <- function(x, i, j, value) {
if (missing(i)) i <- NULL
if (!identical(zcl(i), zcl(activeFilter(value)))) {
halt("Cannot update a variable with an expression that has a different filter")
} else {
.var.updater(x, i, j, value)
}
}
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CrunchVariable", "ANY", "missing", "CrunchExpr"),
.var.updater.crunchobj
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CrunchVariable", "ANY", "missing", "CrunchVariable"),
.var.updater.crunchobj
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CrunchVariable", "ANY", "missing", "CrunchLogicalExpr"),
.backstopUpdate
)
## Set of functions to use in multiple dispatches
.categorical.update <- list(
numeric = function(x, i, j, value) {
if (missing(i)) i <- NULL
if (all(c(NA, -1) %in% value)) {
halt("Cannot have both NA and -1 when specifying category ids")
}
value[is.na(value)] <- -1
invalids <- setdiff(value, ids(categories(x)))
add.no.data <- -1 %in% invalids
invalids <- setdiff(invalids, -1)
if (length(invalids)) {
plural <- length(invalids) > 1
halt(paste0(
"Input value", ifelse(plural, "s ", " "),
serialPaste(invalids), ifelse(plural, " are ", " is "),
"not present in the category ids of variable ", dQuote(name(x))
))
}
if (add.no.data) {
x <- addNoDataCategory(x)
}
out <- .updateVariable(x, value, filter = .dispatchFilter(i))
return(x)
},
character = function(x, i, j, value) {
if (missing(i)) i <- NULL
value[is.na(value)] <- "No Data"
invalids <- setdiff(value, names(categories(x)))
add.no.data <- "No Data" %in% invalids
invalids <- setdiff(invalids, "No Data")
if (length(invalids)) {
plural <- length(invalids) > 1
halt(paste0(
"Input value", ifelse(plural, "s ", " "),
serialPaste(invalids), ifelse(plural, " are ", " is "),
"not present in the category names of variable ",
dQuote(name(x))
))
}
if (add.no.data) {
x <- addNoDataCategory(x)
}
value <- n2i(value, categories(x))
out <- .updateVariable(x, value, filter = .dispatchFilter(i))
return(x)
},
factor = function(x, i, j, value) {
if (missing(i)) i <- NULL
x[i] <- as.character(value) ## Inefficient, but probably fine
return(x)
}
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalVariable", "ANY", "missing", "numeric"),
.categorical.update[["numeric"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalVariable", "ANY", "missing", "character"),
.categorical.update[["character"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalVariable", "ANY", "missing", "factor"),
.categorical.update[["factor"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalArrayVariable", "ANY", "missing", "numeric"),
.categorical.update[["numeric"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalArrayVariable", "ANY", "missing", "character"),
.categorical.update[["character"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CategoricalArrayVariable", "ANY", "missing", "factor"),
.categorical.update[["factor"]]
)
#' @rdname crunch-extract
#' @export
setMethod(
"[<-", c("CrunchVariable", "ANY", "missing", "logical"),
function(x, i, j, value) {
if (all(is.na(value))) {
## For assigning NA
value <- .no.data.value(type(x), add.type = TRUE)
if (has.categories(x)) {
return(.categorical.update[["numeric"]](x, i, j, value))
}
if (missing(i)) i <- NULL
out <- .updateVariable(x, value, filter = .dispatchFilter(i))
return(x)
} else if (has.categories(x) &&
all(names(categories(x)) %in% c("True", "False", "No Data"))) {
## TODO: next, make this more 3VL-aware
## This is "logical-as-categorical", so we can take TRUE/FALSE values
value <- c("True", "False")[2L - as.integer(value)]
return(.categorical.update[["character"]](x, i, j, value))
} else {
## halt()
.backstopUpdate(x, i, j, value)
}
}
)
.no.data.value <- function(x, add.type = FALSE) {
if (has.categories(x)) {
return(NA)
} else {
out <- NA
if (add.type) {
out <- list(value = NA, type = list(class = x))
}
return(out)
}
}
#' @rdname crunch-extract
#' @export
setMethod("is.na<-", "CrunchVariable", function(x, value) {
x[value] <- NA
})
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.