Nothing
## Make the factors for the dispRity object
make.factors <- function(data, group_names, group_variables, time_subsets, pool_time) {
## Extracting the factors
## Getting one group factor
get.group.factors <- function(one_group_variable, factors) {
for(group in 1:length(one_group_variable)) {
factors[grep(one_group_variable[group], factors)] <- one_group_variable[group]
}
return(factors)
}
## Output one factor
output.factor <- function(factors, one_group_variable, data) {
test <- try( factors_out <- data.frame(group = get.group.factors(one_group_variable, factors), row.names = rownames(data$matrix)), silent = TRUE)
if(is(test, "try-error")) {
## Deal with NAs down the line
factors_out <- make.time.factor(data, pool = TRUE, time = FALSE)
} else {
return(factors_out)
}
}
## Make time factor
make.time.factor <- function(data, pool = FALSE, time = TRUE) {
if(time) {
colnames <- "time"
} else {
colnames <- "group"
}
## Get the time data
time_data <- lapply(data$subsets, function(X) return(X$elements))
## Individual time series
make.time.series <- function(one_time_subset, data) {
## Generate the time series
time_series <- matrix(FALSE, ncol = 1, nrow = nrow(data$matrix[[1]]), dimnames = list(rownames(data$matrix)))
time_series[as.vector(one_time_subset), 1] <- TRUE
return(time_series)
}
## Get the data for each time series
groups <- lapply(time_data, make.time.series, data)
groups <- do.call(cbind, groups)
## Naming the groups
if(time) {
colnames(groups) <- paste0("t", gsub(" - ", "to", names(time_data)))
} else {
colnames(groups) <- names(time_data)
}
if(pool) {
## Translating the data
groups <- t(apply(groups, 1, function (X) ifelse(X, names(X), NA)))
groups <- data.frame(matrix(as.factor(apply(groups, 1, function(row) return(na.omit(row)[1]))), ncol = 1, dimnames = list(rownames(data$matrix), colnames)))
} else {
## Binarise the data
if(time) {
groups <- data.frame(ifelse(groups, 1, 0), stringsAsFactors = TRUE)
}
for(col in 1:ncol(groups)) {
groups[,col] <- factor(groups[,col])
}
if(time) {
colnames(groups) <- paste0("t", gsub(" - ", "to", names(time_data)))
} else {
colnames(groups) <- names(time_data)
}
}
return(groups)
}
if(length(group_names) == 1) {
if(time_subsets) {
## Time groups
return(make.time.factor(data, pool = pool_time))
} else {
## Normal groups
## Extract all subsets as a factor list
factors <- names(sort(unlist(lapply(data$subsets, function(X) return(X$elements)))))
## Single group
return(output.factor(factors, group_variables, data))
}
} else {
## Extract all subsets
subsets <- lapply(data$subsets, function(X) return(X$elements))
## Extract the factor list
lapply.subsets <- function(group, subsets) {
names(sort(unlist(sapply(group, function(X) return(subsets[[grep(X, names(subsets))]]), simplify = FALSE))))
}
factors <- lapply(group_variables, lapply.subsets, subsets)
## Multiple groups
groups_out <- do.call(cbind, mapply(output.factor, factors, group_variables, MoreArgs = list(data = data), SIMPLIFY = FALSE))
## Name the groups
colnames(groups_out) <- group_names
return(groups_out)
}
}
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.