--- a +++ b/R/objects.R @@ -0,0 +1,2152 @@ +#' @include zzz.R +#' @include allgenerics.R +NULL + +#### +# Methods #### +#### + +#' Methods for VoltRon +#' +#' Methods for \code{\link{VoltRon}} objects for generics defined in other +#' packages +#' +#' @param x A VoltRon object +#' @param i,value Depends on the usage +#' \describe{ +#' \item{\code{$}, \code{$<-}}{Name (\code{i}) of a single metadata column from the main assay, see \link{vrMainAssay}} +#' \item{\code{[[}, \code{[[<-}}{ +#' If only \code{i} is given, either a vrSample object or a vrAssay for \code{i} (and \code{value}) being name of the sample or assay. +#' If both \code{i} and \code{j} are given, vrLayer with layer name \code{j} (and \code{value}) of vrSample with same name \code{i}. +#' } +#' } +#' @param j Depends on the usage, see \code{i}. +#' @param ... Arguments passed to other methods +#' +#' @name VoltRon-methods +#' @rdname VoltRon-methods +#' +#' @concept voltron +#' +NULL + +## $ method #### + +#' @describeIn VoltRon-methods Metadata access for \code{VoltRon} objects +#' +#' @export +#' @method $ VoltRon +"$.VoltRon" <- function(x, i, ...) { + + # get assay names + assay_names <- vrAssayNames(x) + + # metadata + metadata <- Metadata(x, assay = assay_names) + + # get metadata column + # return(metadata[[i]]) + # return(metadata[,i, drop = TRUE]) + return(as.vector(metadata[[i]])) +} + +#' @describeIn VoltRon-methods Metadata overwrite for \code{VoltRon} objects +#' +#' @export +#' @method $<- VoltRon +"$<-.VoltRon" <- function(x, i, value) { + + # sample metadata + sample.metadata <- SampleMetadata(x) + + # get assay names + assay_names <- vrAssayNames(x) + + # metadata + metadata <- Metadata(x, assay = assay_names) + + # dont change Assays or Layers + if(i %in% c("Assay", "Layer")){ + stop("Changing names of assay types or layers aren't allowed!") + } + + # change/insert either sample names of metadata columns of main assays + if(i == "Sample"){ + if(!any(length(value) %in% c(1,nrow(sample.metadata)))){ + stop("New sample names should of length 1 or the same number of assays!") + } else { + sample.metadata[[i]] <- value + x <- changeSampleNames(x, samples = value) + } + } else { + if(length(value) == 1 | nrow(metadata) == length(value)){ + # metadata[[i]] <- value + # Metadata(x, assay = assay_names) <- metadata + x <- addMetadata(x, assay = assay_names, label = i, value = value) + } else { + stop("The new or the existing column should of length 1 or the same as the number of rows") + } + } + + return(x) +} + +#' @describeIn VoltRon-methods Autocompletion for \code{$} access for \code{VoltRon} objects +#' +#' @inheritParams utils::.DollarNames +#' +#' @importFrom utils .DollarNames +#' @method .DollarNames VoltRon +".DollarNames.VoltRon" <- function(x, pattern = '') { + meta.data <- as.list(x = Metadata(x)) + return(.DollarNames(x = meta.data, pattern = pattern)) +} + +### subset of samples and layers #### + +#' @describeIn VoltRon-methods Accessing vrAssay or vrSample objects from \code{VoltRon} objects +#' +#' @aliases [[,VoltRon-methods +#' @docType methods +#' +#' @export +setMethod( + f = '[[', + signature = c('VoltRon', "character", "missing"), + definition = function(x, i, j, ...){ + + # if no assay were found, check sample names + sample_names <- names(slot(x, "samples")) + + # check query sample name + if(!i %in% sample_names){ + + # check assays + sample.metadata <- SampleMetadata(x) + assay_names <- rownames(sample.metadata) + if(i %in% assay_names){ + cur_assay <- sample.metadata[i,] + assay_list <- x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay + assay_names <- vapply(assay_list, vrAssayNames, character(1)) + return(assay_list[[which(assay_names == rownames(cur_assay))]]) + } else { + stop("There are no samples or assays named ", i, " in this object") + } + + } else { + return(x@samples[[i]]) + } + } +) + +#' @describeIn VoltRon-methods Overwriting vrAssay or vrSample objects from \code{VoltRon} objects +#' +#' @aliases [[<-,VoltRon-methods +#' @docType methods +#' +#' @return \code{[[<-}: \code{x} with the metadata or associated objects added +#' as \code{i}; if \code{value} is \code{NULL}, removes metadata or associated +#' object \code{i} from object \code{x} +#' +#' @export +#' +setMethod( + f = '[[<-', + signature = c('VoltRon', "character", "missing"), + definition = function(x, i, j, ..., value){ + + # sample names + sample_names <- names(slot(x, "samples")) + + # check query sample name + if(!i %in% sample_names){ + + # check assays + sample.metadata <- SampleMetadata(x) + assay_names <- rownames(sample.metadata) + if(i %in% assay_names){ + cur_assay <- sample.metadata[i,] + x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay[[cur_assay$Assay]] <- value + } else { + stop("There are no samples named ", i, " in this object") + } + } else { + if(!inherits(value, "vrSample") & !inherits(value, "vrBlock") ) { + stop("The provided object is not of class vrSample") + } + x@samples[[i]] <- value + } + return(x) + } +) + +#' @describeIn VoltRon-methods Accessing vrLayer objects from \code{VoltRon} objects +#' +#' @aliases [[,VoltRon-methods +#' @docType methods +#' +#' @export +#' +setMethod( + f = '[[', + signature = c('VoltRon', "character", "character"), + definition = function(x, i, j, ...){ + return(x[[i]]@layer[[j]]) + } +) + +#' @describeIn VoltRon-methods Overwriting vrLayer objects from \code{VoltRon} objects +#' +#' @aliases [[<-,VoltRon-methods +#' @docType methods +#' +#' @return \code{[[<-}: \code{x} with the metadata or associated objects added +#' as \code{i}; if \code{value} is \code{NULL}, removes metadata or associated +#' object \code{i} from object \code{x} +#' +#' @export +#' +setMethod( + f = '[[<-', + signature = c('VoltRon', "character", "character"), + definition = function(x, i, j, ..., value){ + + if(!inherits(value, "vrLayer")){ + stop("The provided object is not of class vrLayer") + } + + x[[i]]@layer[[j]] <- value + return(x) + } +) + +### Create VoltRon object #### + +#' formVoltRon +#' +#' Create a VoltRon object +#' +#' @param data the feature matrix of spatialpoints +#' @param metadata a metadata object of class \link{vrMetadata} +#' @param image a singelton or list of images as magick-image objects +#' @param coords the coordinates of the spatial points +#' @param segments the list of segments each associated with a spatial point +#' @param sample.metadata a data frame of the sample metadata, see \link{SampleMetadata} +#' @param main.assay the name of the main assay +#' @param assay.type the type of the assay (tile, molecule, cell, spot or ROI) +#' @param params additional parameters +#' @param sample_name the name of the sample +#' @param layer_name the name of the layer +#' @param image_name the name/key of the image +#' @param feature_name the name/key of the feature set +#' @param project project name +#' @param version the assay version, V1 or V2 +#' @param ... additional parameters passed to \link{formAssay} +#' +#' @importFrom igraph make_empty_graph V vertices +#' @importFrom methods new +#' @importFrom data.table data.table +#' @importFrom rlang %||% +#' @importFrom ids random_id +#' @importFrom Matrix colSums +#' +#' @export +#' +formVoltRon <- function(data = NULL, + metadata = NULL, + image = NULL, + coords, + segments = list(), + sample.metadata = NULL, + main.assay = NULL, + assay.type = "cell", + params = list(), + sample_name = NULL, + layer_name = NULL, + image_name = NULL, + feature_name = NULL, + project = NULL, + version = "v2", ...){ + + # set project name + if(is.null(project)) + project <- "VoltRon" + + # check VoltRon object version + if(!version %in% c("v1", "v2")){ + stop("'version' has to be set to either 'v1' or 'v2'") + } + + # layer and sample names + if(is.null(main.assay)) + main.assay <- paste0("Custom_", assay.type) + layer_name <- ifelse(is.null(layer_name), "Section1", layer_name) + if(main.assay == layer_name) + stop("'", layer_name, "' cannot be a layer name, since main assay is named '", main.assay, "'.") + sample_name <- ifelse(is.null(sample_name), "Sample1", sample_name) + if(main.assay == sample_name) + stop("'", sample_name, "' cannot be a sample name, since main assay is named '", main.assay, "'.") + image_name <- ifelse(is.null(image_name), "image_1", image_name) + + # entity IDs from either the data or metadata + if(!is.null(data)){ + + # check for colnames of the raw data + if(is.null(colnames(data))){ + entityID_nopostfix <- paste0(assay.type, seq_len(ncol(data))) + } else { + entityID_nopostfix <- colnames(data) + } + + } else{ + + # make empty data if data is missing + data <- matrix(nrow = 0, ncol = nrow(metadata)) + + # check for metadata + if(!is.null(metadata)) { + + # check row names if exists + if(is.null(rownames(metadata)) && is.null(metadata$id)){ + entityID_nopostfix <- paste0(assay.type, seq_len(nrow(metadata))) + rownames(metadata) <- entityID + } else { + entityID_nopostfix <- metadata$id %||% rownames(metadata) + } + } else { + stop("Either data or metadata has to be provided to build a VoltRon object") + } + } + + # Metadata + vr_metadata_list <- setVRMetadata(metadata, + data, + entityID_nopostfix, + main.assay, + assay.type, + sample_name, + layer_name, + version) + vr_metadata <- vr_metadata_list$vr_metadata + entityID <- vr_metadata_list$entityID + colnames(data) <- entityID + + # Coordinates + if(!is.null(coords)){ + if(inherits(coords, "data.frame")){ + coords <- as.matrix(coords) + } + if(!inherits(coords, "matrix")){ + stop("Coordinates table should either of a matrix or data.frame class!") + } + if(ncol(coords) == 2){ + coords <- cbind(coords,0) + } else if(ncol(coords) == 3){ + rownames(coords) <- entityID + } else { + stop("The length of colnames of the coordinates matrix should be either two or three!") + } + rownames(coords) <- entityID + colnames(coords) <- c("x", "y", "z") + } else { + stop("There are no coordinate matrix provided!") + } + + # create vrAssay + Assay <- formAssay(data = data, + coords = coords, + segments = segments, + image = image, + params = params, + type = assay.type, + name = "Assay1", + main_image = image_name, + main_featureset = feature_name, + ...) + listofAssays <- list(Assay) + names(listofAssays) <- main.assay + + # create layers + listofLayers <- list(methods::new("vrLayer", + assay = listofAssays, + connectivity = igraph::make_empty_graph(directed = FALSE) + igraph::vertices(entityID))) + names(listofLayers) <- layer_name + + # create samples + listofSamples <- list(methods::new("vrBlock", + layer = listofLayers, + zlocation = c("Section1" = 0), + adjacency = matrix(0, nrow = 1, ncol = 1, + dimnames = list("Section1", "Section1")))) + + + names(listofSamples) <- sample_name + + # set sample meta data + if(is.null(sample.metadata)){ + sample.metadata <- setVRSampleMetadata(listofSamples) + } + + # set VoltRon class + methods::new("VoltRon", samples = listofSamples, metadata = vr_metadata, sample.metadata = sample.metadata, main.assay = main.assay, project = project) +} + +### Assay Methods #### + +updateAssayVoltRon <- function(object, assay = NULL) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # set embeddings + for(assy in assay_names) + object[[assy]] <- updateAssay(object[[assy]]) + + return(object) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname updateAssay +#' @method updateAssay VoltRon +#' @export +setMethod("updateAssay", "VoltRon", updateAssayVoltRon) + +#' Main Assay +#' +#' Get and set the main assay of a VoltRon object +#' +#' @param object a VoltRon object +#' @rdname vrMainAssay +#' +#' @export +setMethod("vrMainAssay", "VoltRon", function(object) { + object@main.assay +}) + +#' @rdname vrMainAssay +#' +#' @export +setMethod("vrMainAssay<-", "VoltRon", function(object, value) { + sample.metadata <- SampleMetadata(object) + assay_names <- unique(sample.metadata$Assay) + if(!value %in% assay_names){ + stop("There is no assay names '", value, "' in this object") + } else { + object@main.assay <- value + } + return(object) +}) + +addAssayVoltRon <- function(object, assay, metadata = NULL, assay_name, sample = "Sample1", layer = "Section1"){ + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # get assay id + assay_ids <- as.numeric(gsub("Assay", "", rownames(sample.metadata))) + assay_id <- paste0("Assay", max(assay_ids)+1) + assay_names <- c(rownames(sample.metadata), assay_id) + + # update sample.metadata and metadata + object@sample.metadata <- rbind(sample.metadata, c(assay_name, layer, sample)) + rownames(object@sample.metadata) <- assay_names + object@metadata <- addAssay(object@metadata, metadata = metadata, + assay = assay, assay_name = assay_name, + sample = sample, layer = layer) + + # get sample and layer + curlayer <- object[[sample, layer]] + assay_list <- curlayer@assay + + # change assay name and add to the layer + vrAssayNames(assay) <- assay_id + new_assay_list <- list(assay) + names(new_assay_list) <- assay_name + assay_list <- c(assay_list, new_assay_list) + object[[sample, layer]]@assay <- assay_list + + # add connectivities of assay to the layer + catch_connect <- try(slot(curlayer, name = "connectivity"), silent = TRUE) + if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ + g_assay <- igraph::make_empty_graph(directed = FALSE) + igraph::vertices(vrSpatialPoints(object, assay = assay_id)) + g_layer <- curlayer@connectivity + g_assay + object[[sample, layer]]@connectivity <- g_layer + } + + # return + return(object) +} + +#' @param assay a vrAssay object +#' @param metadata a predefined metadata +#' @param assay_name assay name of the new added assay +#' @param sample sample name +#' @param layer layer name +#' +#' @rdname addAssay +#' @method addAssay VoltRon +#' +#' @importFrom igraph make_empty_graph add_edges vertices +#' +#' @export +setMethod("addAssay", "VoltRon", addAssayVoltRon) + +vrAssayNamesVoltRon <- function(object, assay = NULL){ + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # check assays + if(is.null(assay)) + assay <- vrMainAssay(object) + + # get assay names + if(any(assay == "all")){ + assay_names <- rownames(sample.metadata) + } else { + if(all(assay %in% sample.metadata$Assay)){ + assay_names <- rownames(sample.metadata)[sample.metadata$Assay %in% assay] + } else { + if(all(assay %in% rownames(sample.metadata))) { + assay_names <- assay + } else { + stop("Assay name or type is not found in the object") + } + } + } + + return(assay_names) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrAssayNames +#' @order 2 +#' @export +setMethod("vrAssayNames", "VoltRon", vrAssayNamesVoltRon) + +vrAssayTypesVoltRon <- function(object, assay = NULL){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get assay types + assay_types <- vapply(assay_names, function(x) vrAssayTypes(object[[x]]), character(1)) + + return(assay_types) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrAssayTypes +#' @order 2 +#' +#' @export +setMethod("vrAssayTypes", "VoltRon", vrAssayTypesVoltRon) + +changeSampleNamesVoltRon <- function(object, samples = NULL){ + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # old to new samples table + samples_table <- data.frame(sample.metadata, AssayID = rownames(sample.metadata), NewSample = samples) + + # check if multiple new sample names are associated with the same section of one sample + check_samples_table <- samples_table %>% + dplyr::group_by(Assay, Sample) %>% dplyr::mutate(n = dplyr::n_distinct(NewSample)) %>% + select(c("Assay", "Sample", "n")) %>% distinct() + if(any(check_samples_table$n > 1)){ + message("Overwriting the sample names of assays that were original from a single layer of a sample aren't allowed") + stop("Check Sample Metadata for the correct Sample reassignment") + } + + # assign new sample names to samples and sample metadata + new_sample.metadata <- NULL + new_listofSamples <- list() + for(cur_sample in unique(samples)){ + + # current sample and sample table + cur_sample.metadata <- samples_table[samples_table$NewSample == cur_sample,] + + # for each unique sample names, combine layers and multiple samples into one + listofLayers <- NULL + uniq_old_samples <- unique(cur_sample.metadata$Sample) + for(i in seq_len(length(uniq_old_samples))){ + listofLayers <- c(listofLayers, object[[uniq_old_samples[i]]]@layer) + } + cur_sample.metadata$comb <- paste(cur_sample.metadata$Sample, cur_sample.metadata$Layer, sep = "_") + cur_sample.metadata$NewLayer <- paste0("Section", as.numeric(factor(cur_sample.metadata$comb, levels = unique(cur_sample.metadata$comb)))) + # names(listofLayers) <- cur_sample.metadata$NewLayer + names(listofLayers) <- unique(cur_sample.metadata$NewLayer) ## CHANGE THIS LATER IF NEEDED #### + + # make layer adjacency and get distance + adjacency <- matrix(0, nrow = length(listofLayers), ncol = length(listofLayers), + dimnames = list(names(listofLayers), names(listofLayers))) + diag(adjacency) <- 1 + # distance <- matrix(NA, nrow = length(listofLayers), ncol = length(listofLayers), + # dimnames = list(names(listofLayers), names(listofLayers))) + # diag(distance) <- 0 + zlocation <- rep(0,length(listofLayers)) + names(zlocation) <- names(listofLayers) + + # make new block + # listofSamples <- list(methods::new("vrBlock", + # layer = listofLayers, adjacency = adjacency, distance = distance)) + listofSamples <- list(methods::new("vrBlock", + layer = listofLayers, zlocation = zlocation, adjacency = adjacency)) + names(listofSamples) <- cur_sample + new_listofSamples <- c(new_listofSamples, listofSamples) + new_sample.metadata <- rbind(new_sample.metadata, cur_sample.metadata) + } + + # assign new samples and layers to metadata + metadata <- changeSampleNames(Metadata(object, type = "all"), sample_metadata_table = new_sample.metadata) + + # sample metadata + new_sample.metadata <- new_sample.metadata[,c("Assay", "NewLayer", "NewSample")] + colnames(new_sample.metadata) <- c("Assay", "Layer", "Sample") + + # reinsert object elements + object@sample.metadata <- new_sample.metadata + object@samples <- new_listofSamples + object@metadata <- metadata + + # return + return(object) +} + +#' changeSampleNames.VoltRon +#' +#' Change the sample names of the VoltRon object and reorient layers if needed +#' +#' @param samples a single or a set of sample names +#' +#' @rdname changeSampleNames +#' +#' @importFrom dplyr n_distinct %>% distinct select mutate group_by +#' @importFrom methods new +#' +#' @noRd +setMethod("changeSampleNames", "VoltRon", changeSampleNamesVoltRon) + +changeAssayNamesVoltRon <- function(object, assays = NULL){ + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # check the length of the new assay names + if(nrow(sample.metadata) != length(assays)) + stop("The set of new assay names should be of the number of assays in the VoltRon object.") + + # check the uniqueness of the assay names + if(length(unique(assays)) != length(assays)) + stop("Each new assay name should be unique") + + # attach new names of sample.metadata + sample.metadata$NewAssayNames <- assays + + # change assay names in layers + samples <- unique(sample.metadata$Sample) + for(samp in samples){ + object[[samp]] <- changeAssayNames(object[[samp]], sample.metadata = sample.metadata[sample.metadata$Sample == samp,]) + } + + # return + return(object) +} + +#' changeAssayNames.VoltRon +#' +#' Change the sample names of the VoltRon object and reorient layers if needed +#' +#' @rdname changeAssayNames +#' @method changeAssayNames VoltRon +#' +#' @param object a VoltRon object +#' @param assays a set of assay names +#' +#' @noRd +setMethod("changeAssayNames", "VoltRon", changeAssayNamesVoltRon) + +#' addLayerConnectivity +#' +#' add connectivity information to the assays (vrAssay) of the same layer (vrLayer) +#' +#' @param object a VoltRon object +#' @param connectivity a metadata of edges representing connected spatial points across assays +#' @param sample sample name +#' @param layer layer name +#' +#' @importFrom igraph add_edges +#' +#' @noRd +addLayerConnectivity <- function(object, connectivity, sample, layer){ + + # get sample and layer + curlayer <- object[[sample, layer]] + + # make edges from connectivity matrix + connectivity <- as.vector(t(as.matrix(connectivity))) + + # add edges + object[[sample, layer]]@connectivity <- igraph::add_edges(curlayer@connectivity, edges = connectivity) + + # return + return(object) +} + +### Layer Methods #### + +#' addBlockConnectivity +#' +#' add connectivity information to the layers (vrLayer) of the same block (Block) +#' +#' @param object a VoltRon object +#' @param connectivity a metadata of edges representing connected layers within a block +#' @param zlocation +#' @param sample sample name +#' +#' @noRd +addBlockConnectivity <- function(object, connectivity, zlocation = NULL, sample){ + + # get sample and layer + cursample <- object[[sample]] + + # update z location/coordinates + if(!is.null(zlocation)){ + cursample@zlocation[names(cursample@zlocation)] <- zlocation + } + + # update adjacency + adjacency <- cursample@adjacency + for(i in seq_len(nrow(connectivity))){ + adjacency[connectivity[i,1], connectivity[i,2]] <- + adjacency[connectivity[i,2], connectivity[i,1]] <- 1 + } + cursample@adjacency <- adjacency + + # return sample + object[[sample]] <- cursample + + # return + return(object) +} + +#' getBlockConnectivity +#' +#' get connected assays +#' +#' @param object a VoltRon object +#' @param connectivity a metadata of edges representing connected layers within a block +#' @param zlocation +#' @param sample sample name +#' +#' @importFrom igraph components graph_from_adjacency_matrix +#' +#' @noRd +getBlockConnectivity <- function(object, assay){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get samples + sample_metadata <- SampleMetadata(object) + samples <- unique(sample_metadata[assay_names, "Sample"]) + + # get list of connected assays + assay_list <- list() + for(samp in samples){ + cur_sample_metadata <- sample_metadata[sample_metadata$Sample == samp,] + cur_assaynames <- assay_names[assay_names %in% rownames(cur_sample_metadata)] + cur_sections <- cur_sample_metadata[cur_assaynames, "Layer"] + + catch_connect <- try(slot(object[[samp]], name = "adjacency"), silent = TRUE) + if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ + adjacency <- object[[samp]]@adjacency + adjacency <- adjacency[match(cur_sections,rownames(adjacency)), match(cur_sections,rownames(adjacency)), drop = FALSE] + colnames(adjacency) <- rownames(adjacency) <- cur_assaynames + components <- igraph::components(igraph::graph_from_adjacency_matrix(adjacency)) + assay_list <- c(assay_list, split(names(components$membership), components$membership)) + } else { + assay_list <- c(assay_list, cur_assaynames) + } + } + + # return list + assay_list +} + +### Object Methods #### + +subsetVoltRon <- function(x, subset, samples = NULL, assays = NULL, spatialpoints = NULL, features = NULL, image = NULL, interactive = FALSE, use.points.only = FALSE, + shiny.options = list(launch.browser = getOption("shiny.launch.browser", interactive()))) { + + # start + object <- x + + # subseting based on subset argument + if (!missing(x = subset)) { + # subset_data <- subset + subset <- rlang::enquo(arg = subset) + } + if(!missing(subset)){ + metadata <- Metadata(object) + name <- strsplit(rlang::quo_text(subset), split = " ")[[1]][1] + if(name %in% colnames(metadata)){ + if(inherits(metadata, "data.table")){ + spatialpoints <- metadata$id[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] + } else if(inherits(metadata, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))){ + stop("Direct subsetting for Ondisk VoltRon objects are currently not possible!") + # spatialpoints <- as.vector(metadata$id)[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] + } else { + if(!is.null(rownames(metadata))){ + cur_data <- rownames(metadata) + } else { + cur_data <- metadata$id + } + spatialpoints <- rownames(metadata)[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] + } + } else { + stop("Column '", name, "' is not found in the metadata") + } + object <- subsetVoltRon(object, spatialpoints = spatialpoints) + return(object) + } + + # subseting on other attributes + attrinfo <- c(vapply(list(samples, assays, spatialpoints, features), function(x) length(x) > 0, logical(1)), interactive) + if(sum(attrinfo) > 1){ + stop("Please choose only one of the subsetting attributes: 'samples', 'assays', 'spatialpoints', 'features' or 'interactive'") + } + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # subsetting + if(!is.null(samples)){ + + # check assays associated with samples and subset for assays + if(all(samples %in% sample.metadata$Sample)){ + assays <- rownames(sample.metadata)[sample.metadata$Sample %in% samples] + # return(subset.VoltRon(object, assays = assays)) + return(subsetVoltRon(object, assays = assays)) + } else { + stop("Some requested samples are not found in this VoltRon object!") + } + + } else if(!is.null(assays)){ + + # subset for assays + sample.metadata <- subset_sampleMetadata(sample.metadata, assays = assays) + # metadata <- subset.vrMetadata(Metadata(object, type = "all"), assays = assays) + metadata <- subsetvrMetadata(Metadata(object, type = "all"), assays = assays) + samples <- unique(sample.metadata$Sample) + listofSamples <- sapply(object@samples[samples], function(samp) { + # subset.vrSample(samp, assays = assays) + subsetvrSample(samp, assays = assays) + }, USE.NAMES = TRUE) + + } else if(!is.null(spatialpoints)) { + + # subsetting on entity names + # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + samples <- vrSampleNames(metadata) + listofSamples <- sapply(object@samples[samples], function(samp) { + subsetvrSample(samp, spatialpoints = spatialpoints) + }, USE.NAMES = TRUE) + # spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints.vrSample)) + spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints)) + # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + sample.metadata <- subset_sampleMetadata(sample.metadata, assays = vrAssayNamesvrMetadata(metadata)) + + } else if(!is.null(features)){ + + # subsetting on features + assay_names <- vrAssayNames(object) + for(assy in assay_names){ + if(inherits(object[[assy]], "vrAssay")){ + # object[[assy]] <- subset.vrAssay(object[[assy]], features = features) + object[[assy]] <- subsetvrAssay(object[[assy]], features = features) + } else { + # object[[assy]] <- subset.vrAssayV2(object[[assy]], features = features) + object[[assy]] <- subsetvrAssay(object[[assy]], features = features) + } + } + metadata <- Metadata(object, type = "all") + listofSamples <- object@samples + + } else if(!is.null(image)) { + + # subsetting on image + if(inherits(image, "character")){ + + # check if there are only one image and one assay + numlayers <- paste0(sample.metadata$Layer, sample.metadata$Sample) + if(length(unique(numlayers)) > 1){ + stop("Subseting on images can only be performed on VoltRon objects with a single layer") + } else { + samples <- unique(sample.metadata$Sample) + listofSamples <- sapply(object@samples[samples], function(samp) { + subsetvrSample(samp, image = image) + }, USE.NAMES = TRUE) + # spatialpoints <- do.call(c, lapply(listofSamples, vrSpatialPoints.vrSample)) + spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints)) + # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) + } + } else { + stop("Please provide a character based subsetting notation, see magick::image_crop documentation") + } + } else if(interactive){ + + # interactive subsetting + results <- demuxVoltRon(object, use.points.only = use.points.only, shiny.options = shiny.options) + return(results) + } + + # main.assay + main.assay <- unique(sample.metadata$Assay)[unique(sample.metadata$Assay) == names(table(sample.metadata$Assay))[which.max(table(sample.metadata$Assay))]] + + # project + project <- object@project + + # subset graphs + graph_list <- subset_graphs(object, + spatialpoints = vrSpatialPoints(metadata, assay = vrAssayNames(object))) + + # set VoltRon class + methods::new("VoltRon", + samples = listofSamples, metadata = metadata, sample.metadata = sample.metadata, + graph = graph_list, main.assay = main.assay, project = project) +} + +#' Subsetting VoltRon objects +#' +#' Given a VoltRon object, subset the object given one of the attributes +#' +#' @param x a VoltRon object +#' @param subset Logical statement for subsetting +#' @param samples the set of samples to subset the object +#' @param assays the set of assays to subset the object +#' @param spatialpoints the set of spatial points to subset the object +#' @param features the set of features to subset the object +#' @param image the subseting string passed to \link{image_crop} +#' @param interactive TRUE if interactive subsetting on the image is demanded +#' @param use.points.only if \code{interactive} is \code{TRUE}, use spatial points instead of the reference image +#' @param shiny.options a list of shiny options (launch.browser, host, port etc.) passed \code{options} arguement of \link{shinyApp}. For more information, see \link{runApp} +#' +#' @rdname subset +#' @aliases subset +#' @method subset VoltRon +#' +#' @importFrom rlang enquo eval_tidy quo_get_expr quo_text +#' @importFrom stringr str_extract +#' @importFrom methods new +#' +#' @export +#' +#' @examples +#' # example data +#' data("visium_data") +#' +#' # subset based on assay +#' subset(visium_data, assays = "Assay1") +#' subset(visium_data, assays = "Visium") +#' +#' # subset based on samples +#' subset(visium_data, samples = "Anterior1") +#' +#' # subset based on assay +#' subset(visium_data, spatialpoints = c("GTTATATTATCTCCCT-1_Assay1", "GTTTGGGTTTCGCCCG-1_Assay1")) +#' +#' # subset based on features +#' subset(visium_data, features = c("Map3k19", "Rab3gap1")) +#' +#' # interactive subsetting +#' \dontrun{ +#' visium_subset_data <- subset(visium_data, interactive = TRUE) +#' visium_subset <- visium_subset_data$subsets[[1]] +#' } +setMethod("subset", "VoltRon", subsetVoltRon) + +mergeVoltRon <- function(x, y, samples = NULL, main.assay = NULL, verbose = TRUE) { + + # start + object <- x + object_list <- y + + # combine all elements + if(!is.list(object_list)) + object_list <- list(object_list) + object_list <- c(object, object_list) + + # check if all are VoltRon + if(!all(lapply(object_list, class) == "VoltRon")) + stop("All arguements have to be of VoltRon class") + + # sample metadata list + sample.metadata_list <- lapply(object_list, function(x) slot(x, name = "sample.metadata")) + + # old assay names + old_assay_names <- do.call(c, lapply(sample.metadata_list, rownames)) + + # merge sample metadata + sample.metadata <- merge_sampleMetadata(sample.metadata_list) + + # merge metadata and sample metadata + if(verbose) + message("Merging metadata ...") + metadata_list <- lapply(object_list, function(x) slot(x, name = "metadata")) + metadata <- mergevrMetadata(metadata_list[[1]], metadata_list[-1]) + + # combine samples and rename layers + if(verbose) + message("Merging blocks and layers ...") + listofSamples <- NULL + for(i in seq_len(length(object_list))){ + cur_object <- object_list[[i]]@samples + listofSamples <- c(listofSamples, cur_object) + } + + # get main assay + if(is.null(main.assay)) + main.assay <- names(sort(table(sample.metadata$Assay), decreasing = TRUE))[1] + + # project + project <- slot(object_list[[1]], "project") + + # set VoltRon class + object <- methods::new("VoltRon", samples = listofSamples, metadata = metadata, sample.metadata = sample.metadata, main.assay = main.assay, project = project) + + # change assay names and sample names + object <- changeAssayNames(object, assays = rownames(sample.metadata)) + + # change sample names + if(!is.null(samples)) + object$Sample <- samples + + # return + object +} + +#' Merging VoltRon objects +#' +#' Given a VoltRon object, and a list of VoltRon objects, merge all. +#' +#' @param x a VoltRon Object +#' @param y a single or a list of VoltRon objects +#' @param samples a single sample name or multiple sample names of the same size as the given VoltRon objects +#' @param main.assay the name of the main assay +#' @param verbose verbose +#' +#' @rdname merge +#' @aliases merge +#' @method merge VoltRon +#' @importFrom methods new +#' +#' @export +setMethod("merge", signature = "VoltRon", mergeVoltRon) + +#' @rdname vrSpatialPoints +#' @order 2 +#' +#' @export +setMethod("vrSpatialPoints", "VoltRon", function(object, assay = NULL) { + + # get assays + assay <- vrAssayNames(object, assay = assay) + + # return + return(vrSpatialPoints(object@metadata, assay = assay)) +}) + +vrFeaturesVoltRon <- function(object, assay = NULL) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get all features + features <- NULL + for(assy in assay_names) + features <- c(features, vrFeatures(object[[assy]])) + + return(unique(features)) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrFeatures +#' @method vrFeatures VoltRon +#' @order 2 +#' @export +setMethod("vrFeatures", "VoltRon", vrFeaturesVoltRon) + +vrFeatureDataVoltRon <- function(object, assay = NULL, feat_type = NULL) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get all features + features <- vrFeatureData(object[[assay_names[1]]], feat_type = feat_type) + + # return + return(features) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrFeatureData +#' @order 2 +#' @export +setMethod("vrFeatureData", "VoltRon", vrFeatureDataVoltRon) + +vrFeatureDataReplaceVoltRon <- function(object, assay = NULL, value) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # set embeddings + for(assy in assay_names) + vrFeatureData(object[[assy]]) <- value + + return(object) +} + +#' @param value new feature metadata +#' +#' @rdname vrFeatureData +#' @order 4 +#' @export +setMethod("vrFeatureData<-", "VoltRon", vrFeatureDataReplaceVoltRon) + +vrDataVoltRon <- function(object, assay = NULL, features = NULL, feat_type = NULL, norm = FALSE, ...) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get all coordinates + data <- NULL + for(i in seq_len(length(assay_names))){ + cur_data <- vrData(object[[assay_names[i]]], features = features, feat_type = feat_type, norm = norm, ...) + if(inherits(cur_data, c("dgCMatrix", "CsparseMatrix", "dsparseMatrix"))){ + cur_data <- as.matrix(cur_data) + } + if(inherits(cur_data, c("data.frame", "Matrix", "matrix"))){ + cur_data <- data.frame(cur_data, feature.ID = rownames(cur_data), check.names = FALSE) + } + if(i == 1){ + data <- cur_data + } else { + data <- merge_data(data, cur_data, by = "feature.ID") + } + } + if("feature.ID" %in% colnames(data)){ + rownames(data) <- data$feature.ID + data <- data[,!colnames(data) %in% "feature.ID"] + data <- as.matrix(data) + data <- replaceNaMatrix(data, 0) + colnames(data) <- gsub("\\.","-", colnames(data)) + } + + return(data) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param features the set of features +#' @param feat_type the feature set type +#' @param norm TRUE if normalized data should be returned +#' @param ... additional parameters passed to other methods and \link{vrImages} +#' +#' @rdname vrData +#' @order 2 +#' +#' @importFrom dplyr full_join mutate_all coalesce +#' +#' @export +setMethod("vrData", "VoltRon", vrDataVoltRon) + +#' @importFrom Matrix Matrix +merge_data <- function(data1, data2, by = "feature.ID"){ + if(inherits(data1, c("data.frame", "Matrix"))){ + + # merge + data1 <- dplyr::full_join(data1, data2, by = "feature.ID") + + } else if(inherits(data1, c("IterableMatrix"))) { + rownames_all <- unique(c(rownames(data1), rownames(data2))) + + # first data + m <- Matrix::Matrix(nrow = length(rownames_all) - length(rownames(data1)), ncol = ncol(data1), data = 0, sparse = TRUE) + data1_new <- rbind(data1, m) + rownames(data1_new) <- c(rownames(data1), setdiff(rownames_all, rownames(data1))) + data1_new <- data1_new[rownames_all,] + + # second data + m <- Matrix::Matrix(nrow = length(rownames_all) - length(rownames(data2)), ncol = ncol(data2), data = 0, sparse = TRUE) + data2_new <- rbind(data2, m) + rownames(data2_new) <- c(rownames(data2), setdiff(rownames_all, rownames(data2))) + data2_new <- data2_new[rownames_all,] + + # merge + data1 <- cbind(data1_new, data2_new) + } + return(data1) +} + +generateTileDataVoltRon <- function(object, assay = NULL, ...) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # check if assay types are all tiles + assay_types <- vrAssayTypes(object, assay = assay) + if(!all(assay_types == "tile")) + stop("generateTileData can only be used for tile-based assays") + + # get tile data for all assays + for(assy in assay_names) + object[[assy]] <- generateTileData(object[[assy]], ...) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param ... additional parameters passed to vrAssay. +#' +#' @rdname generateTileData +#' @order 2 +#' +#' @export +setMethod("generateTileData", "VoltRon", generateTileDataVoltRon) + +vrEmbeddingsVoltRon <- function(object, assay = NULL, type = "pca", dims = seq_len(30)) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get all coordinates + returndata_list <- list() + for(i in seq_len(length(assay_names))) + returndata_list[[i]] <- vrEmbeddings(object[[assay_names[i]]], type = type, dims = dims) + + return(do.call(rbind, returndata_list)) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param type the key name for the embedding, i.e. "pca" or "umap" +#' @param dims the set of dimensions of the embedding data +#' +#' @rdname vrEmbeddings +#' @order 2 +#' +#' @export +setMethod("vrEmbeddings", "VoltRon", vrEmbeddingsVoltRon) + +vrEmbeddingsReplaceVoltRon <- function(object, assay = NULL, type = "pca", overwrite = FALSE, value) { + + # check if the embedding exists + if(type %in% vrEmbeddingNames(object) && !overwrite) + stop("An embedding named '", type, "' already exists in this object. Do overwrite = TRUE for replacing with the existing one.") + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # set embeddings + for(assy in assay_names){ + assayobject <- object[[assy]] + if(vrAssayTypes(assayobject) %in% c("ROI", "cell", "spot")){ + vrEmbeddings(assayobject, type = type) <- value[grepl(paste0(assy, "$"), rownames(value)),, drop = FALSE] + } else { + vrEmbeddings(assayobject, type = type) <- value[vrSpatialPoints(assayobject),, drop = FALSE] + } + object[[assy]] <- assayobject + } + + return(object) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param type the key name for the embedding +#' @param overwrite Whether the existing embedding with name 'type' should be overwritten +#' @param value new embedding data +#' +#' @rdname vrEmbeddings +#' @order 4 +#' +#' @export +setMethod("vrEmbeddings<-", "VoltRon", vrEmbeddingsReplaceVoltRon) + +vrEmbeddingNamesVoltRon <- function(object, assay = NULL){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get assay types + embed_names <- unique(unlist(lapply(assay_names, function(x) vrEmbeddingNames(object[[x]])))) + + return(embed_names) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrEmbeddingNames +#' @order 2 +#' +#' @export +setMethod("vrEmbeddingNames", "VoltRon", vrEmbeddingNamesVoltRon) + +#### Feature #### + +addFeatureVoltRon <- function(object, assay = NULL, data, feature_name){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + if(length(assay_names) > 1){ + stop("You cannot add new features to multiple assays at once!") + } + + # add assay + object[[assay_names]] <- addFeature(object[[assay_names]], data = data, feature_name = feature_name) + + # return + return(object) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' If NULL, the default assay will be used, see \link{vrMainAssay}. If given as "all", then provides a summary of spatial systems across all assays. +#' @param data new data matrix for new feature set +#' @param feature_name the name of the new feature set +#' +#' @rdname addFeature +#' @method addFeature VoltRon +#' +#' @importFrom stringr str_replace +#' +#' @export +setMethod("addFeature", "VoltRon", addFeatureVoltRon) + +vrMainFeatureTypeVoltRon <- function(object, assay = NULL){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # if assay = all, give a summary + if(!is.null(assay)){ + if(assay == "all"){ + featuretype_names <- unlist(lapply(rownames(SampleMetadata(object)), function(x) paste(vrMainFeatureType(object[[x]]), collapse = ","))) + featuretype_names <- data.frame(Assay = assay_names, Feature = featuretype_names) + return(featuretype_names) + } + } + + # get assay types + featuretype_names <- unlist(lapply(assay_names, function(x) vrMainFeatureType(object[[x]]))) + + # return data + if(!is.null(featuretype_names)){ + featuretype_data <- data.frame(Assay = assay_names, Feature = featuretype_names) + return(featuretype_data) + } else { + return(NULL) + } +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' If NULL, the default assay will be used, see \link{vrMainAssay}. If given as "all", then provides a summary of spatial systems across all assays. +#' +#' @rdname vrMainFeatureType +#' @order 2 +#' @export +setMethod("vrMainFeatureType", "VoltRon", vrMainFeatureTypeVoltRon) + +vrMainFeatureTypeReplaceVoltRon <- function(object, assay = NULL, value){ + + # sample metadata + sample_metadata <- SampleMetadata(object) + + # assays + assay_names <- vrAssayNames(object, assay = assay) + unique_assays <- unique(sample_metadata[assay_names, "Assay"]) + if(length(unique_assays) > 1){ + stop("You can only set the main feature type of a single assay type") + } else { + for(assy in assay_names){ + vrMainFeatureType(object[[assy]], ignore = TRUE) <- value + } + } + + return(object) +} + +#' @rdname vrMainFeatureType +#' @order 4 +#' @export +setMethod("vrMainFeatureType<-", "VoltRon", vrMainFeatureTypeReplaceVoltRon) + +vrFeatureTypeNamesVoltRon <- function(object, assay = NULL){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # if assay = all, give a summary + if(!is.null(assay)){ + if(assay == "all"){ + feature_names <- unlist(lapply(assay_names, function(x) paste(vrFeatureTypeNames(object[[x]]), collapse = ","))) + feature_names <- data.frame(Assay = assay_names, Feature = feature_names) + return(feature_names) + } + } + + feature_names <- unique(unlist(lapply(assay_names, function(x) vrFeatureTypeNames(object[[x]])))) + + return(feature_names) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' If NULL, the default assay will be used, see \link{vrMainAssay}. If given as "all", then provides a summary of spatial systems across all assays +#' +#' @rdname vrFeatureTypeNames +#' +#' @export +setMethod("vrFeatureTypeNames", "VoltRon", vrFeatureTypeNamesVoltRon) + +#### Metadata #### + +MetadataVoltRon <- function(object, assay = NULL, type = NULL){ + + # check type + if(!is.null(type)){ + + if(type == "all"){ + return(object@metadata) + } else { + if(!is.null(assay)){ + stop("Please specify either assay or type, not both!") + } + if(type %in% methods::slotNames(object@metadata)){ + return(slot(object@metadata, name = type)) + } + } + } else{ + type <- unique(vrAssayTypes(object, assay = assay)) + if(length(type) > 1) + stop("You cannot get the metadata of multiple spatial entity types in the same time! See SampleMetadata()") + } + + # get assay metadata from matching type + if(type %in% methods::slotNames(object@metadata)){ + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get metadata + metadata <- slot(object@metadata, name = type) + if(inherits(metadata, "data.table")){ + metadata <- subset(metadata, assay_id %in% assay_names) + } else if(inherits(metadata, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))){ + if("assay_id" %in% colnames(metadata)){ + metadata_list <- list() + for(assy in assay_names){ + metadata_list[[assy]] <- metadata[metadata$assay_id == assy,] + } + metadata <- do.call("rbind", metadata_list) + } else { + ind <- stringr::str_extract(as.vector(metadata$id), "Assay[0-9]+") %in% assay_names + metadata <- metadata[ind,] + } + } else { + metadata <- metadata[stringr::str_extract(rownames(metadata), "Assay[0-9]+") %in% assay_names, ] + } + return(metadata) + } else { + stop("Please provide one of five assay types: 'ROI', 'cell', 'spot', 'molecule' or 'tile'.") + } +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param type the assay type: ROI, spot or cell, or all for the entire metadata object +#' +#' @rdname Metadata +#' +#' @importFrom methods slotNames +#' @export +setMethod("Metadata", "VoltRon", MetadataVoltRon) + +MetadataReplaceVoltRon <- function(object, assay = NULL, type = NULL, value) { + + if(!is.data.frame(value) && !inherits(value, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))) + stop("The new or updated metadata has to be a data frame") + + `%notin%` <- Negate(`%in%`) + if(is.null(rownames(value)) && "id" %notin% colnames(value)) + stop("The new metadata should have row names or a column called 'id' to match its rows with the existing one") + + if(is.null(type)){ + type <- unique(vrAssayTypes(object, assay = assay)) + } + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # get assay names + # assay_names <- vrAssayNames(object, assay = assay) + + # get metadata + metadata <- slot(object@metadata, name = type) + + if("id" %in% colnames(metadata)){ + + # replace the metadata (or some part of it) with the new value + if(length(setdiff(value$id, metadata$id)) == 0){ + + # check columns of the new table + new_columns <- setdiff(colnames(value), colnames(metadata)) + + # current metadata shouldnt have columns that value doesnt have + if(length(setdiff(colnames(metadata), colnames(value))) > 0) + stop("Some columns of new data frame are not available in the metadata") + + # if new columns appear, update the column names of the metadata' + if(length(new_columns) > 0){ + if(inherits(metadata, "data.table")){ + value <- value[,colnames(value)[colnames(value) %in% c(colnames(metadata), new_columns)], with = FALSE] + } else { + value <- value[,c(colnames(metadata), new_columns)] + } + for(cur_col in new_columns){ + if(is.numeric(value[[cur_col]])){ + metadata[[cur_col]] <- NA + } else { + metadata[[cur_col]] <- "" + } + } + } + + # replace data + if(!inherits(metadata, "DataFrame")){ + # TODO: is this replace method appropriate for all dataframe types ? + # metadata[match(value$id, metadata$id), ] <- value + ind <- match(value$id, metadata$id) + for(cur_col in new_columns){ + metadata[[cur_col]][ind] <- value[[cur_col]] + } + } else { + ind <- match(as.vector(value$id), as.vector(metadata$id)) + for(cur_col in new_columns){ + metadata[[cur_col]][ind] <- value[[cur_col]] + } + } + slot(object@metadata, name = type) <- metadata + + } else { + stop("Some rows of new data frame are not available in the metadata") + } + + } else if(!is.null(rownames(metadata))){ + + # replace the metadata (or some part of it) with the new value + if(length(setdiff(rownames(value), rownames(metadata))) == 0){ + + # check columns of the new table + new_columns <- setdiff(colnames(value), colnames(metadata)) + + # current metadata shouldn't have columns that value doesnt have + if(length(setdiff(colnames(metadata), colnames(value))) > 0) + stop("Some columns of new data frame are not available in the metadata") + + # if new columns appear, update the column names of the metadata' + if(length(new_columns) > 0){ + value <- value[,c(colnames(metadata), new_columns)] + for(cur_col in new_columns){ + if(is.numeric(value[[cur_col]])){ + metadata[[cur_col]] <- NA + } else { + metadata[[cur_col]] <- "" + } + } + } + + # replace data + metadata[rownames(value), ] <- value + slot(object@metadata, name = type) <- metadata + } else { + stop("Some rows of new data frame are not available in the metadata") + } + + } else { + stop("The metadata should either have rownames or a column called 'id'!") + } + + return(object) +} + +#' @param value new metadata +#' +#' @rdname Metadata +#' @method Metadata<- VoltRon +#' +#' @export +setMethod("Metadata<-", "VoltRon", MetadataReplaceVoltRon) + +#' addMetadata +#' +#' adding new columns or updating the values of the existing columns +#' +#' @param object a VoltRon object +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param type the assay type: ROI, spot or cell, or all for the entire metadata object +#' @param value the new values of the metadata column +#' @param label the label of the new column, either a new column or an existing one +#' +#' @export +addMetadata <- function(object, assay = NULL, type = NULL, value, label) { + + if(!inherits(object, "VoltRon")) + stop("Object must be of VoltRon class!") + + # auxiliary + `%notin%` <- Negate(`%in%`) + + # check type + if(is.null(type)){ + type <- unique(vrAssayTypes(object, assay = assay)) + if(length(type) > 1){ + stop("You cannot update the metadata of multiple spatial entity types in the same time! See SampleMetadata()") + } + } + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # get assay names + entities <- vrSpatialPoints(object, assay = assay) + + # get metadata + metadata <- slot(object@metadata, name = type) + + # add or replace the new column + if(label %notin% colnames(metadata)){ + + # add empty values if the column is new + if(is.numeric(value)){ + metadata[[label]] <- NA + } else { + metadata[[label]] <- "" + } + } + + # replace data + if(length(value) == length(entities) || length(value) == 1){ + if(is.null(rownames(metadata)) || inherits(metadata, "data.table")){ + metadata[[label]][match(entities, as.vector(metadata$id))] <- value + } else { + metadata[entities,][[label]] <- value + } + } else { + stop("value should be of the same length as the rows of metadata or 1!") + } + + # replace metadata + slot(object@metadata, name = type) <- metadata + + # return + return(object) +} + + +#' SampleMetadata +#' +#' Get the sample metadata of a VoltRon object +#' +#' @param object a VoltRon object +#' +#' @export +SampleMetadata <- function(object) { + object@sample.metadata +} + +#### Spatial #### + +vrCoordinatesVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, reg = FALSE) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get sample metadata + sample_metadata <- SampleMetadata(object) + + # get spatial name + if(!is.null(spatial_name)) + image_name <- spatial_name + + # get all coordinates + coords <- NULL + for(assy in assay_names){ + + # get coordinates + cur_coords <- vrCoordinates(object[[assy]], image_name = image_name, reg = reg) + if(inherits(cur_coords, "IterableMatrix")) + cur_coords <- as.matrix(as(cur_coords, "dgCMatrix")) + + # update zlocation + sample_name <- sample_metadata[assy, "Sample"] + + catch_connect <- try(slot(object[[sample_name]], name = "zlocation"), silent = TRUE) + if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ + zlocation <- object[[sample_name]]@zlocation + cur_coords[,"z"] <- rep(zlocation[sample_metadata[assy, "Layer"]], nrow(cur_coords)) + } + + # merge coordinates + if(!is.null(coords)){ + coords <- rbind(coords, cur_coords) + } else { + coords <- cur_coords + } + } + + # return image + return(coords) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image associated with the coordinates +#' @param spatial_name the name/key of the spatial system associated with the coordinates +#' @param reg TRUE if registered coordinates of the main image (\link{vrMainImage}) is requested +#' +#' @rdname vrCoordinates +#' @order 2 +#' @export +setMethod("vrCoordinates", "VoltRon", vrCoordinatesVoltRon) + +vrCoordinatesReplaceVoltRon <- function(object, image_name = NULL, spatial_name = NULL, reg = FALSE, value) { + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # check the number of assays in the object + if(nrow(sample.metadata) > 1) + stop("Changing the coordinates of multiple assays in the same time are not permitted!") + + # get assay + cur_assay <- sample.metadata[1,] + vrlayer <- object[[cur_assay$Sample, cur_assay$Layer]] + vrassay <- vrlayer[[cur_assay$Assay]] + + # get spatial name + if(!is.null(spatial_name)) + image_name <- spatial_name + + # change coordinates + vrCoordinates(vrassay, spatial_name = image_name, reg = reg) <- value + vrlayer[[cur_assay$Assay]] <- vrassay + object[[cur_assay$Sample, cur_assay$Layer]] <- vrlayer + + return(object) +} + +#' @param value new coordinates of spatial points +#' +#' @rdname vrCoordinates +#' @order 4 +#' @export +setMethod("vrCoordinates<-", "VoltRon", vrCoordinatesReplaceVoltRon) + +vrSegmentsVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, reg = FALSE, as.data.frame = FALSE) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get spatial name + if(!is.null(spatial_name)) + image_name <- spatial_name + + # get all coordinates + segts <- NULL + for(assy in assay_names) + segts <- c(segts, vrSegments(object[[assy]], spatial_name = image_name, reg = reg)) + + if(as.data.frame) + segts <- do.call(rbind, segts) + + # return image + return(segts) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image associated with the coordinates +#' @param spatial_name the name/key of the spatial system associated with the coordinates +#' @param reg TRUE if registered coordinates of the main image (\link{vrMainImage}) is requested +#' @param as.data.frame if TRUE, the coordinates of segment nodes will be returned as a data frame +#' +#' @rdname vrSegments +#' @order 2 +#' @export +setMethod("vrSegments", "VoltRon", vrSegmentsVoltRon) + +vrSegmentsReplaceVoltRon <- function(object, image_name = NULL, spatial_name = NULL, reg = FALSE, value) { + + # sample metadata + sample.metadata <- SampleMetadata(object) + + # check the number of assays in the object + if(nrow(sample.metadata) > 1) + stop("Changing the coordinates of multiple assays are not permitted!") + + # get assay + cur_assay <- sample.metadata[1,] + vrlayer <- object[[cur_assay$Sample, cur_assay$Layer]] + vrassay <- vrlayer[[cur_assay$Assay]] + + # get spatial name + if(!is.null(spatial_name)) + image_name <- spatial_name + + # change coordinates + vrSegments(vrassay, spatial_name = image_name, reg = reg) <- value + vrlayer[[cur_assay$Assay]] <- vrassay + object[[cur_assay$Sample, cur_assay$Layer]] <- vrlayer + + return(object) +} + +#' @param value new segment coordinates of spatial points +#' +#' @rdname vrSegments +#' @order 5 +#' @export +setMethod("vrSegments<-", "VoltRon", vrSegmentsReplaceVoltRon) + +flipCoordinatesVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, ...){ + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + + # get spatial name + if(!is.null(spatial_name)) + image_name <- spatial_name + + # flip coordinates + for(assy in assay_names){ + object[[assy]] <- flipCoordinates(object[[assy]], spatial_name = image_name, ...) + } + return(object) +} + +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image +#' @param spatial_name the name/key of the spatial system associated with the coordinates +#' @param ... additional parameters passed to \link{vrCoordinates} and \link{vrSegments} +#' +#' @rdname flipCoordinates +#' @order 2 +#' +#' @export +setMethod("flipCoordinates", "VoltRon", flipCoordinatesVoltRon) + +#### Graphs #### + +#' vrGraph +#' +#' Get graph of a VoltRon object +#' +#' @param object a VoltRon object +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' @param graph.type the type of the graph, either custom or given by \link{getProfileNeighbors} or \link{getSpatialNeighbors} functions +#' +#' @rdname vrGraph +#' +#' @importFrom igraph induced_subgraph V +#' +#' @export +vrGraph <- function(object, assay = NULL, graph.type = NULL) { + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + node_names <- vrSpatialPoints(object, assay = assay_names) + + # check if there exists graphs + if(length(names(object@graph)) == 0) + stop("There are no graphs in this VoltRon object!") + + # check graph type + if(is.null(graph.type)){ + graph.type <- vrGraphNames(object) + if(length(graph.type) == 0){ + stop("There are no graphs in this VoltRon object!") + } + graph.type <- graph.type[1] + } else { + if(!graph.type %in% vrGraphNames(object)) + stop("The graph name '", graph.type, "' can't be found in this VoltRon object!") + } + + # return graph + if(length(vrGraphNames(object)) > 0){ + node_names <- intersect(igraph::V(object@graph[[graph.type]])$name, node_names) + returngraph <- igraph::induced_subgraph(object@graph[[graph.type]], node_names) + return(returngraph) + } else { + warning("This VoltRon object does not have any graphs yet!") + return(NULL) + } +} + +#' @param value new graph +#' +#' @rdname vrGraph +#' +#' @importFrom igraph disjoint_union induced_subgraph V +#' @export +"vrGraph<-" <- function(object, assay = NULL, graph.type = "kNN", value) { + + # check value + if(!inherits(value, "igraph")) + stop("The 'value' should be of an igraph class!") + + # get assay names + assay_names <- vrAssayNames(object, assay = assay) + spobject <- vrSpatialPoints(object, assay = assay_names) + + # check if there exists graphs + graph <- object@graph + if(length(names(object@graph)) == 0 || !graph.type %in% names(object@graph)){ + + # graph[[graph.type]] <- make_empty_graph(directed = FALSE) + vertices(spobject) + graph[[graph.type]] <- value + + } else { + + # vertices + new_vert <- igraph::V(value)$name + + # edges + subg_inv <- igraph::induced_subgraph(graph[[graph.type]], spobject[!spobject%in%new_vert]) + graph[[graph.type]] <- igraph::disjoint_union(value, subg_inv) + } + + # update object + object@graph <- graph + + # return + return(object) +} + +#' vrGraphNames +#' +#' Get names of all graphs +#' +#' @param object a VoltRon object +#' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. +#' if NULL, the default assay will be used, see \link{vrMainAssay}. +#' +#' @rdname vrGraphNames +#' +#' @export +vrGraphNames <- function(object, assay = NULL){ + return(names(object@graph)) +} + +#' subset_graphs +#' +#' Given a VoltRon object and a vrMetadata, subset the graph +#' +#' @param object a VoltRon Object +#' @param spatialpoints a set of spatial points +#' +#' @importFrom igraph subgraph V +#' +#' @noRd +subset_graphs <- function(object, spatialpoints){ + + # graph names + graphnames <- vrGraphNames(object) + + # for all graphs + if(!is.null(graphnames)){ + graph_list <- object@graph + for(g in vrGraphNames(object)){ + cur_graph <- graph_list[[g]] + cur_graph<- igraph::subgraph(cur_graph, igraph::V(cur_graph)[names(igraph::V(cur_graph)) %in% spatialpoints]) + graph_list[[g]] <- cur_graph + } + } else { + graph_list <- list() + } + + return(graph_list) +} + +#' merge_graphs +#' +#' Given a VoltRon object, and a list of VoltRon objects, merge their graphs. +#' +#' @param object a VoltRon Object +#' @param object_list a list of VoltRon objects +#' +#' @importFrom igraph disjoint_union +#' +#' @noRd +merge_graphs <- function(object, object_list){ + + # combine all elements + if(!is.list(object_list)) + object_list <- list(object_list) + if(inherits(object, "VoltRon")){ + object_list <- c(object, object_list) + } else { + object_list <- c(list(object), object_list) + } + + # choose objects + obj1 <- object_list[[1]] + obj2 <- object_list[[2]] + + # initial combination + if(length(object_list) > 2){ + combined_graph <- merge_graphs(obj1, obj2) + for(i in 3:(length(object_list))){ + combined_graph <- merge_graphs(combined_graph, object_list[[i]]) + } + } else { + updateobjects <- updateGraphAssay(obj1, obj2) + obj1 <- updateobjects$object1 + obj2 <- updateobjects$object2 + combined_graph <- igraph::disjoint_union(obj1, obj2) + } + + return(combined_graph) +} + +#' updateGraphAssay +#' +#' @param object1 VoltRon object +#' @param object2 VoltRon object +#' +#' @importFrom igraph V +#' @importFrom stringr str_extract +#' +#' @noRd +updateGraphAssay <- function(object1, object2){ + + if(inherits(object1, "VoltRon")) + object1 <- vrGraph(object1, assay = "all") + if(inherits(object2, "VoltRon")) + object2 <- vrGraph(object2, assay = "all") + + # get assay types + assaytype <- unique(stringr::str_extract(igraph::V(object1)$name, "Assay[0-9]+$")) + assaytype <- assaytype[order(nchar(assaytype), assaytype)] + + # replace assay names + replacement <- paste0("Assay", seq_len(length(assaytype))) + vertex_names <- igraph::V(object1)$name + temp <- vertex_names + for(i in seq_len(length(assaytype))) + temp[grepl(paste0(assaytype[i],"$"), vertex_names)] <- gsub(paste0(assaytype[i],"$"), replacement[i], + vertex_names[grepl(paste0(assaytype[i],"$"), vertex_names)]) + igraph::V(object1)$name <- temp + + # get assay types + assaytype <- unique(stringr::str_extract(igraph::V(object2)$name, "Assay[0-9]+$")) + assaytype <- assaytype[order(nchar(assaytype), assaytype)] + + # replace assay names + replacement <- paste0("Assay", (length(replacement)+1):(length(replacement) + length(assaytype))) + vertex_names <- igraph::V(object2)$name + temp <- vertex_names + for(i in seq_len(length(assaytype))) + temp[grepl(paste0(assaytype[i],"$"), vertex_names)] <- gsub(paste0(assaytype[i],"$"), replacement[i], + vertex_names[grepl(paste0(assaytype[i],"$"), vertex_names)]) + igraph::V(object2)$name <- temp + + # return + return(list(object1 = object1, object2 = object2)) +} + +#' combineGraphs +#' +#' Combining the edges of multiple graphs +#' +#' @param object a VoltRon Object +#' @param graph.names a vector of graph names +#' @param graph.weights the weights for edges of each graph. +#' @param graph.key the name of the combined graph +#' +#' @importFrom igraph union edge_attr_names as_adjacency_matrix graph_from_adjacency_matrix +#' +#' @export +combineGraphs <- function(object, graph.names = NULL, graph.weights = NULL, graph.key = "combined"){ + + if(!inherits(object, "VoltRon")) + stop("Object must be of VoltRon class!") + + if(length(graph.names) == 0) + stop("Please provide graph names") + + if(any(!graph.names %in% vrGraphNames(object))){ + graph.names <- setdiff(graph.names, vrGraphNames(object)) + stop("The following graphs are not included in the VoltRon object: ", + paste(graph.names, sep = ",", collapse = TRUE)) + } + + # check weights + if(is.null(graph.weights)){ + graph.weights <- rep(0.5, length(graph.names)) + } + if(length(graph.weights) != length(graph.names)){ + stop("The weights should be of the length of graph names") + } + if(any(!is.numeric(graph.weights))){ + stop("Weights should be numeric") + } + if(sum(graph.weights) != 1){ + stop("Weights should sum up to 1!") + } + names(graph.weights) <- graph.names + + # collect graphs + allmat <- NULL + for(gr in graph.names){ + cur_graph <- vrGraph(object, graph.type = gr) + if("weight" %in% igraph::edge_attr_names(cur_graph)){ + adjmat <- igraph::as_adjacency_matrix(cur_graph, attr = "weight") + } else { + adjmat <- igraph::as_adjacency_matrix(cur_graph) + } + adjmat <- adjmat*graph.weights[gr] + if(is.null(allmat)){ + allmat <- adjmat + } else { + allmat <- allmat + adjmat + } + } + + # union of graphs + vrGraph(object, graph.type = graph.key) <- igraph::graph_from_adjacency_matrix(allmat, mode = "undirected", weighted = TRUE, diag = FALSE) + + # return + return(object) +} +