Nothing
process_data <- function(data, filter, by, free.scales, is.colors, split.by=TRUE, vary) {
nby <- nlevels(by)
cls <- check_tm_classes(data, is.colors)
if (any(!filter)) {
data[!filter, ] <- NA
by[!filter] <- NA
}
if (nby > 1) {
nx <- nby
dat <- data[[1]]
if (cls[1]=="cha") {
dat <- as.factor(dat)
cls[1] <- "fac"
}
if (cls[1]=="log") {
dat <- factor(dat, levels = c("FALSE", "TRUE"))
cls[1] <- "fac"
}
if (cls[1]=="fac") xlvls <- levels(dat)
X <- lapply(levels(by), function(l) {
sel <- by==l
sel[is.na(sel)] <- FALSE
dat2 <- if (cls[1]=="fac") {
ch <- as.character(dat)
ch[!sel] <- NA
lvls <- if (free.scales) intersect(xlvls, ch) else xlvls
factor(ch, levels=lvls)
} else {
if (split.by) dat[!sel] <- NA
dat
}
attr(dat2, "sel") <- sel
dat2
})
Xsel <- lapply(X, attr, "sel")
names(X) <- levels(by)
if (cls[1]=="col" || !vary) {
M <- do.call(cbind, X) #matrix(unlist(X), ncol=nby)
sel <- do.call(cbind, Xsel) #matrix(unlist(Xsel), ncol=nby)
attr(M, "sel") <- sel
attr(M, "anyNA") <- apply(is.na(M) & sel, MARGIN = 2, any)
attr(M, "allNA") <- !apply(!is.na(M) & sel, MARGIN = 2, any)
return(M)
} else if (!free.scales) {
Y <- unlist(X, use.names = FALSE)
attr(Y, "sel") <- unlist(Xsel, use.names = FALSE)
} else {
Y <- X
attr(Y, "sel") <- do.call(cbind, Xsel) #matrix(unlist(Xsel), ncol=nby)
}
attr(Y, "anyNA") <- vapply(X, function(i) any(is.na(i) & attr(i, "sel")), logical(1))
attr(Y, "allNA") <- vapply(X, function(i) all(is.na(i)[attr(i, "sel")]), logical(1))
return(Y)
} else {
#data[!filter, ] <- NA
sel <- matrix(filter, nrow = nrow(data), ncol=ncol(data))
anyNA <- !apply(sel, MARGIN = 2, all)
allNA <- !apply(sel, MARGIN = 2, any)
if (all(cls=="col") || !vary) {
m <- as.matrix(data)
attr(m, "sel") <- sel
attr(m, "anyNA") <- anyNA
attr(m, "allNA") <- allNA
return(m)
}
if (!free.scales) {
if (all(cls %in% c("num", "uni"))) {
if (all(cls == "uni")) {
uni <- attr(data[[1]], "units")
data <- lapply(data, function(dvec) {
convert_to_num_with_unit_attr(dvec, uni)
})
}
datavec <- unlist(data, use.names = FALSE)
if (all(cls == "uni")) attr(datavec, "units") <- as.character(uni)
} else {
xlvls_list <- mapply(function(d, cl){
if (cl=="fac") {
levels(d)
} else if (cl=="log") {
c("FALSE", "TRUE")
} else na.omit(unique(d))
}, data, cls, SIMPLIFY=FALSE)
xlvls <- unique(unlist(xlvls_list, use.names = FALSE))
datavec <- factor(unlist(lapply(data, as.character), use.names = FALSE), levels=xlvls)
}
attr(datavec, "sel") <- sel
attr(datavec, "anyNA") <- anyNA
attr(datavec, "allNA") <- allNA
return(datavec)
} else {
if (any(cls=="cha")) data[cls=="cha"] <- lapply(data[cls=="cha"], as.factor)
if (any(cls=="log")) data[cls=="log"] <- lapply(data[cls=="log"], factor, levels = c("FALSE", "TRUE"))
if (ncol(data)==1) {
datavec <- data[[1]]
if (all(cls == "uni")) {
datavec <- convert_to_num_with_unit_attr(datavec)
} else if (any(cls == "uni")) {
datavec <- as.numeric(datavec)
}
attr(datavec, "sel") <- sel
attr(datavec, "anyNA") <- anyNA
attr(datavec, "allNA") <- allNA
return(datavec)
} else {
datalist <- as.list(data)
datalist <- mapply(function(datavec, cl) {
if (cl == "cha") {
as.factor(datavec)
} else if (cl == "uni") {
datavec <- convert_to_num_with_unit_attr(datavec)
} else datavec
}, datalist, cls, SIMPLIFY = FALSE)
attr(datalist, "sel") <- sel #as.list(as.data.frame(sel))
attr(datalist, "anyNA") <- anyNA
attr(datalist, "allNA") <- allNA
return(datalist)
}
}
}
}
convert_to_num_with_unit_attr <- function(x, uni = NULL) {
if (is.null(uni)) {
uni <- attr(x, "units")
} else {
x <- set_units(x, uni, mode = "standard")
}
uni_char <- as.character(uni)
x <- as.numeric(x)
attr(x, "units") <- uni_char
x
}
check_tm_classes <- function(x, is.colors) {
if (is.colors) {
rep("col", ncol(x))
} else {
vapply(x, function(y) {
if (inherits(y, "units")) {
"uni"
} else if (is.numeric(y)) {
"num"
} else if (is.factor(y)) {
"fac"
} else if (is.logical(y)) {
"log"
} else if (all(valid_colors(y))) {
"col"
} else "cha"
}, character(1))
}
}
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.