Datasets
Models
Diff of
/R/objects.R
[000000]
..
[413088]
Switch to unified view
| a | b/R/objects.R | ||
|---|---|---|---|
| 1 | #' @include zzz.R |
||
| 2 | #' @include allgenerics.R |
||
| 3 | NULL |
||
| 4 | |||
| 5 | #### |
||
| 6 | # Methods #### |
||
| 7 | #### |
||
| 8 | |||
| 9 | #' Methods for VoltRon |
||
| 10 | #' |
||
| 11 | #' Methods for \code{\link{VoltRon}} objects for generics defined in other |
||
| 12 | #' packages |
||
| 13 | #' |
||
| 14 | #' @param x A VoltRon object |
||
| 15 | #' @param i,value Depends on the usage |
||
| 16 | #' \describe{ |
||
| 17 | #' \item{\code{$}, \code{$<-}}{Name (\code{i}) of a single metadata column from the main assay, see \link{vrMainAssay}} |
||
| 18 | #' \item{\code{[[}, \code{[[<-}}{ |
||
| 19 | #' 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. |
||
| 20 | #' 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}. |
||
| 21 | #' } |
||
| 22 | #' } |
||
| 23 | #' @param j Depends on the usage, see \code{i}. |
||
| 24 | #' @param ... Arguments passed to other methods |
||
| 25 | #' |
||
| 26 | #' @name VoltRon-methods |
||
| 27 | #' @rdname VoltRon-methods |
||
| 28 | #' |
||
| 29 | #' @concept voltron |
||
| 30 | #' |
||
| 31 | NULL |
||
| 32 | |||
| 33 | ## $ method #### |
||
| 34 | |||
| 35 | #' @describeIn VoltRon-methods Metadata access for \code{VoltRon} objects |
||
| 36 | #' |
||
| 37 | #' @export |
||
| 38 | #' @method $ VoltRon |
||
| 39 | "$.VoltRon" <- function(x, i, ...) { |
||
| 40 | |||
| 41 | # get assay names |
||
| 42 | assay_names <- vrAssayNames(x) |
||
| 43 | |||
| 44 | # metadata |
||
| 45 | metadata <- Metadata(x, assay = assay_names) |
||
| 46 | |||
| 47 | # get metadata column |
||
| 48 | # return(metadata[[i]]) |
||
| 49 | # return(metadata[,i, drop = TRUE]) |
||
| 50 | return(as.vector(metadata[[i]])) |
||
| 51 | } |
||
| 52 | |||
| 53 | #' @describeIn VoltRon-methods Metadata overwrite for \code{VoltRon} objects |
||
| 54 | #' |
||
| 55 | #' @export |
||
| 56 | #' @method $<- VoltRon |
||
| 57 | "$<-.VoltRon" <- function(x, i, value) { |
||
| 58 | |||
| 59 | # sample metadata |
||
| 60 | sample.metadata <- SampleMetadata(x) |
||
| 61 | |||
| 62 | # get assay names |
||
| 63 | assay_names <- vrAssayNames(x) |
||
| 64 | |||
| 65 | # metadata |
||
| 66 | metadata <- Metadata(x, assay = assay_names) |
||
| 67 | |||
| 68 | # dont change Assays or Layers |
||
| 69 | if(i %in% c("Assay", "Layer")){ |
||
| 70 | stop("Changing names of assay types or layers aren't allowed!") |
||
| 71 | } |
||
| 72 | |||
| 73 | # change/insert either sample names of metadata columns of main assays |
||
| 74 | if(i == "Sample"){ |
||
| 75 | if(!any(length(value) %in% c(1,nrow(sample.metadata)))){ |
||
| 76 | stop("New sample names should of length 1 or the same number of assays!") |
||
| 77 | } else { |
||
| 78 | sample.metadata[[i]] <- value |
||
| 79 | x <- changeSampleNames(x, samples = value) |
||
| 80 | } |
||
| 81 | } else { |
||
| 82 | if(length(value) == 1 | nrow(metadata) == length(value)){ |
||
| 83 | # metadata[[i]] <- value |
||
| 84 | # Metadata(x, assay = assay_names) <- metadata |
||
| 85 | x <- addMetadata(x, assay = assay_names, label = i, value = value) |
||
| 86 | } else { |
||
| 87 | stop("The new or the existing column should of length 1 or the same as the number of rows") |
||
| 88 | } |
||
| 89 | } |
||
| 90 | |||
| 91 | return(x) |
||
| 92 | } |
||
| 93 | |||
| 94 | #' @describeIn VoltRon-methods Autocompletion for \code{$} access for \code{VoltRon} objects |
||
| 95 | #' |
||
| 96 | #' @inheritParams utils::.DollarNames |
||
| 97 | #' |
||
| 98 | #' @importFrom utils .DollarNames |
||
| 99 | #' @method .DollarNames VoltRon |
||
| 100 | ".DollarNames.VoltRon" <- function(x, pattern = '') { |
||
| 101 | meta.data <- as.list(x = Metadata(x)) |
||
| 102 | return(.DollarNames(x = meta.data, pattern = pattern)) |
||
| 103 | } |
||
| 104 | |||
| 105 | ### subset of samples and layers #### |
||
| 106 | |||
| 107 | #' @describeIn VoltRon-methods Accessing vrAssay or vrSample objects from \code{VoltRon} objects |
||
| 108 | #' |
||
| 109 | #' @aliases [[,VoltRon-methods |
||
| 110 | #' @docType methods |
||
| 111 | #' |
||
| 112 | #' @export |
||
| 113 | setMethod( |
||
| 114 | f = '[[', |
||
| 115 | signature = c('VoltRon', "character", "missing"), |
||
| 116 | definition = function(x, i, j, ...){ |
||
| 117 | |||
| 118 | # if no assay were found, check sample names |
||
| 119 | sample_names <- names(slot(x, "samples")) |
||
| 120 | |||
| 121 | # check query sample name |
||
| 122 | if(!i %in% sample_names){ |
||
| 123 | |||
| 124 | # check assays |
||
| 125 | sample.metadata <- SampleMetadata(x) |
||
| 126 | assay_names <- rownames(sample.metadata) |
||
| 127 | if(i %in% assay_names){ |
||
| 128 | cur_assay <- sample.metadata[i,] |
||
| 129 | assay_list <- x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay |
||
| 130 | assay_names <- vapply(assay_list, vrAssayNames, character(1)) |
||
| 131 | return(assay_list[[which(assay_names == rownames(cur_assay))]]) |
||
| 132 | } else { |
||
| 133 | stop("There are no samples or assays named ", i, " in this object") |
||
| 134 | } |
||
| 135 | |||
| 136 | } else { |
||
| 137 | return(x@samples[[i]]) |
||
| 138 | } |
||
| 139 | } |
||
| 140 | ) |
||
| 141 | |||
| 142 | #' @describeIn VoltRon-methods Overwriting vrAssay or vrSample objects from \code{VoltRon} objects |
||
| 143 | #' |
||
| 144 | #' @aliases [[<-,VoltRon-methods |
||
| 145 | #' @docType methods |
||
| 146 | #' |
||
| 147 | #' @return \code{[[<-}: \code{x} with the metadata or associated objects added |
||
| 148 | #' as \code{i}; if \code{value} is \code{NULL}, removes metadata or associated |
||
| 149 | #' object \code{i} from object \code{x} |
||
| 150 | #' |
||
| 151 | #' @export |
||
| 152 | #' |
||
| 153 | setMethod( |
||
| 154 | f = '[[<-', |
||
| 155 | signature = c('VoltRon', "character", "missing"), |
||
| 156 | definition = function(x, i, j, ..., value){ |
||
| 157 | |||
| 158 | # sample names |
||
| 159 | sample_names <- names(slot(x, "samples")) |
||
| 160 | |||
| 161 | # check query sample name |
||
| 162 | if(!i %in% sample_names){ |
||
| 163 | |||
| 164 | # check assays |
||
| 165 | sample.metadata <- SampleMetadata(x) |
||
| 166 | assay_names <- rownames(sample.metadata) |
||
| 167 | if(i %in% assay_names){ |
||
| 168 | cur_assay <- sample.metadata[i,] |
||
| 169 | x@samples[[cur_assay$Sample]]@layer[[cur_assay$Layer]]@assay[[cur_assay$Assay]] <- value |
||
| 170 | } else { |
||
| 171 | stop("There are no samples named ", i, " in this object") |
||
| 172 | } |
||
| 173 | } else { |
||
| 174 | if(!inherits(value, "vrSample") & !inherits(value, "vrBlock") ) { |
||
| 175 | stop("The provided object is not of class vrSample") |
||
| 176 | } |
||
| 177 | x@samples[[i]] <- value |
||
| 178 | } |
||
| 179 | return(x) |
||
| 180 | } |
||
| 181 | ) |
||
| 182 | |||
| 183 | #' @describeIn VoltRon-methods Accessing vrLayer objects from \code{VoltRon} objects |
||
| 184 | #' |
||
| 185 | #' @aliases [[,VoltRon-methods |
||
| 186 | #' @docType methods |
||
| 187 | #' |
||
| 188 | #' @export |
||
| 189 | #' |
||
| 190 | setMethod( |
||
| 191 | f = '[[', |
||
| 192 | signature = c('VoltRon', "character", "character"), |
||
| 193 | definition = function(x, i, j, ...){ |
||
| 194 | return(x[[i]]@layer[[j]]) |
||
| 195 | } |
||
| 196 | ) |
||
| 197 | |||
| 198 | #' @describeIn VoltRon-methods Overwriting vrLayer objects from \code{VoltRon} objects |
||
| 199 | #' |
||
| 200 | #' @aliases [[<-,VoltRon-methods |
||
| 201 | #' @docType methods |
||
| 202 | #' |
||
| 203 | #' @return \code{[[<-}: \code{x} with the metadata or associated objects added |
||
| 204 | #' as \code{i}; if \code{value} is \code{NULL}, removes metadata or associated |
||
| 205 | #' object \code{i} from object \code{x} |
||
| 206 | #' |
||
| 207 | #' @export |
||
| 208 | #' |
||
| 209 | setMethod( |
||
| 210 | f = '[[<-', |
||
| 211 | signature = c('VoltRon', "character", "character"), |
||
| 212 | definition = function(x, i, j, ..., value){ |
||
| 213 | |||
| 214 | if(!inherits(value, "vrLayer")){ |
||
| 215 | stop("The provided object is not of class vrLayer") |
||
| 216 | } |
||
| 217 | |||
| 218 | x[[i]]@layer[[j]] <- value |
||
| 219 | return(x) |
||
| 220 | } |
||
| 221 | ) |
||
| 222 | |||
| 223 | ### Create VoltRon object #### |
||
| 224 | |||
| 225 | #' formVoltRon |
||
| 226 | #' |
||
| 227 | #' Create a VoltRon object |
||
| 228 | #' |
||
| 229 | #' @param data the feature matrix of spatialpoints |
||
| 230 | #' @param metadata a metadata object of class \link{vrMetadata} |
||
| 231 | #' @param image a singelton or list of images as magick-image objects |
||
| 232 | #' @param coords the coordinates of the spatial points |
||
| 233 | #' @param segments the list of segments each associated with a spatial point |
||
| 234 | #' @param sample.metadata a data frame of the sample metadata, see \link{SampleMetadata} |
||
| 235 | #' @param main.assay the name of the main assay |
||
| 236 | #' @param assay.type the type of the assay (tile, molecule, cell, spot or ROI) |
||
| 237 | #' @param params additional parameters |
||
| 238 | #' @param sample_name the name of the sample |
||
| 239 | #' @param layer_name the name of the layer |
||
| 240 | #' @param image_name the name/key of the image |
||
| 241 | #' @param feature_name the name/key of the feature set |
||
| 242 | #' @param project project name |
||
| 243 | #' @param version the assay version, V1 or V2 |
||
| 244 | #' @param ... additional parameters passed to \link{formAssay} |
||
| 245 | #' |
||
| 246 | #' @importFrom igraph make_empty_graph V vertices |
||
| 247 | #' @importFrom methods new |
||
| 248 | #' @importFrom data.table data.table |
||
| 249 | #' @importFrom rlang %||% |
||
| 250 | #' @importFrom ids random_id |
||
| 251 | #' @importFrom Matrix colSums |
||
| 252 | #' |
||
| 253 | #' @export |
||
| 254 | #' |
||
| 255 | formVoltRon <- function(data = NULL, |
||
| 256 | metadata = NULL, |
||
| 257 | image = NULL, |
||
| 258 | coords, |
||
| 259 | segments = list(), |
||
| 260 | sample.metadata = NULL, |
||
| 261 | main.assay = NULL, |
||
| 262 | assay.type = "cell", |
||
| 263 | params = list(), |
||
| 264 | sample_name = NULL, |
||
| 265 | layer_name = NULL, |
||
| 266 | image_name = NULL, |
||
| 267 | feature_name = NULL, |
||
| 268 | project = NULL, |
||
| 269 | version = "v2", ...){ |
||
| 270 | |||
| 271 | # set project name |
||
| 272 | if(is.null(project)) |
||
| 273 | project <- "VoltRon" |
||
| 274 | |||
| 275 | # check VoltRon object version |
||
| 276 | if(!version %in% c("v1", "v2")){ |
||
| 277 | stop("'version' has to be set to either 'v1' or 'v2'") |
||
| 278 | } |
||
| 279 | |||
| 280 | # layer and sample names |
||
| 281 | if(is.null(main.assay)) |
||
| 282 | main.assay <- paste0("Custom_", assay.type) |
||
| 283 | layer_name <- ifelse(is.null(layer_name), "Section1", layer_name) |
||
| 284 | if(main.assay == layer_name) |
||
| 285 | stop("'", layer_name, "' cannot be a layer name, since main assay is named '", main.assay, "'.") |
||
| 286 | sample_name <- ifelse(is.null(sample_name), "Sample1", sample_name) |
||
| 287 | if(main.assay == sample_name) |
||
| 288 | stop("'", sample_name, "' cannot be a sample name, since main assay is named '", main.assay, "'.") |
||
| 289 | image_name <- ifelse(is.null(image_name), "image_1", image_name) |
||
| 290 | |||
| 291 | # entity IDs from either the data or metadata |
||
| 292 | if(!is.null(data)){ |
||
| 293 | |||
| 294 | # check for colnames of the raw data |
||
| 295 | if(is.null(colnames(data))){ |
||
| 296 | entityID_nopostfix <- paste0(assay.type, seq_len(ncol(data))) |
||
| 297 | } else { |
||
| 298 | entityID_nopostfix <- colnames(data) |
||
| 299 | } |
||
| 300 | |||
| 301 | } else{ |
||
| 302 | |||
| 303 | # make empty data if data is missing |
||
| 304 | data <- matrix(nrow = 0, ncol = nrow(metadata)) |
||
| 305 | |||
| 306 | # check for metadata |
||
| 307 | if(!is.null(metadata)) { |
||
| 308 | |||
| 309 | # check row names if exists |
||
| 310 | if(is.null(rownames(metadata)) && is.null(metadata$id)){ |
||
| 311 | entityID_nopostfix <- paste0(assay.type, seq_len(nrow(metadata))) |
||
| 312 | rownames(metadata) <- entityID |
||
| 313 | } else { |
||
| 314 | entityID_nopostfix <- metadata$id %||% rownames(metadata) |
||
| 315 | } |
||
| 316 | } else { |
||
| 317 | stop("Either data or metadata has to be provided to build a VoltRon object") |
||
| 318 | } |
||
| 319 | } |
||
| 320 | |||
| 321 | # Metadata |
||
| 322 | vr_metadata_list <- setVRMetadata(metadata, |
||
| 323 | data, |
||
| 324 | entityID_nopostfix, |
||
| 325 | main.assay, |
||
| 326 | assay.type, |
||
| 327 | sample_name, |
||
| 328 | layer_name, |
||
| 329 | version) |
||
| 330 | vr_metadata <- vr_metadata_list$vr_metadata |
||
| 331 | entityID <- vr_metadata_list$entityID |
||
| 332 | colnames(data) <- entityID |
||
| 333 | |||
| 334 | # Coordinates |
||
| 335 | if(!is.null(coords)){ |
||
| 336 | if(inherits(coords, "data.frame")){ |
||
| 337 | coords <- as.matrix(coords) |
||
| 338 | } |
||
| 339 | if(!inherits(coords, "matrix")){ |
||
| 340 | stop("Coordinates table should either of a matrix or data.frame class!") |
||
| 341 | } |
||
| 342 | if(ncol(coords) == 2){ |
||
| 343 | coords <- cbind(coords,0) |
||
| 344 | } else if(ncol(coords) == 3){ |
||
| 345 | rownames(coords) <- entityID |
||
| 346 | } else { |
||
| 347 | stop("The length of colnames of the coordinates matrix should be either two or three!") |
||
| 348 | } |
||
| 349 | rownames(coords) <- entityID |
||
| 350 | colnames(coords) <- c("x", "y", "z") |
||
| 351 | } else { |
||
| 352 | stop("There are no coordinate matrix provided!") |
||
| 353 | } |
||
| 354 | |||
| 355 | # create vrAssay |
||
| 356 | Assay <- formAssay(data = data, |
||
| 357 | coords = coords, |
||
| 358 | segments = segments, |
||
| 359 | image = image, |
||
| 360 | params = params, |
||
| 361 | type = assay.type, |
||
| 362 | name = "Assay1", |
||
| 363 | main_image = image_name, |
||
| 364 | main_featureset = feature_name, |
||
| 365 | ...) |
||
| 366 | listofAssays <- list(Assay) |
||
| 367 | names(listofAssays) <- main.assay |
||
| 368 | |||
| 369 | # create layers |
||
| 370 | listofLayers <- list(methods::new("vrLayer", |
||
| 371 | assay = listofAssays, |
||
| 372 | connectivity = igraph::make_empty_graph(directed = FALSE) + igraph::vertices(entityID))) |
||
| 373 | names(listofLayers) <- layer_name |
||
| 374 | |||
| 375 | # create samples |
||
| 376 | listofSamples <- list(methods::new("vrBlock", |
||
| 377 | layer = listofLayers, |
||
| 378 | zlocation = c("Section1" = 0), |
||
| 379 | adjacency = matrix(0, nrow = 1, ncol = 1, |
||
| 380 | dimnames = list("Section1", "Section1")))) |
||
| 381 | |||
| 382 | |||
| 383 | names(listofSamples) <- sample_name |
||
| 384 | |||
| 385 | # set sample meta data |
||
| 386 | if(is.null(sample.metadata)){ |
||
| 387 | sample.metadata <- setVRSampleMetadata(listofSamples) |
||
| 388 | } |
||
| 389 | |||
| 390 | # set VoltRon class |
||
| 391 | methods::new("VoltRon", samples = listofSamples, metadata = vr_metadata, sample.metadata = sample.metadata, main.assay = main.assay, project = project) |
||
| 392 | } |
||
| 393 | |||
| 394 | ### Assay Methods #### |
||
| 395 | |||
| 396 | updateAssayVoltRon <- function(object, assay = NULL) { |
||
| 397 | |||
| 398 | # get assay names |
||
| 399 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 400 | |||
| 401 | # set embeddings |
||
| 402 | for(assy in assay_names) |
||
| 403 | object[[assy]] <- updateAssay(object[[assy]]) |
||
| 404 | |||
| 405 | return(object) |
||
| 406 | } |
||
| 407 | |||
| 408 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 409 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 410 | #' |
||
| 411 | #' @rdname updateAssay |
||
| 412 | #' @method updateAssay VoltRon |
||
| 413 | #' @export |
||
| 414 | setMethod("updateAssay", "VoltRon", updateAssayVoltRon) |
||
| 415 | |||
| 416 | #' Main Assay |
||
| 417 | #' |
||
| 418 | #' Get and set the main assay of a VoltRon object |
||
| 419 | #' |
||
| 420 | #' @param object a VoltRon object |
||
| 421 | #' @rdname vrMainAssay |
||
| 422 | #' |
||
| 423 | #' @export |
||
| 424 | setMethod("vrMainAssay", "VoltRon", function(object) { |
||
| 425 | object@main.assay |
||
| 426 | }) |
||
| 427 | |||
| 428 | #' @rdname vrMainAssay |
||
| 429 | #' |
||
| 430 | #' @export |
||
| 431 | setMethod("vrMainAssay<-", "VoltRon", function(object, value) { |
||
| 432 | sample.metadata <- SampleMetadata(object) |
||
| 433 | assay_names <- unique(sample.metadata$Assay) |
||
| 434 | if(!value %in% assay_names){ |
||
| 435 | stop("There is no assay names '", value, "' in this object") |
||
| 436 | } else { |
||
| 437 | object@main.assay <- value |
||
| 438 | } |
||
| 439 | return(object) |
||
| 440 | }) |
||
| 441 | |||
| 442 | addAssayVoltRon <- function(object, assay, metadata = NULL, assay_name, sample = "Sample1", layer = "Section1"){ |
||
| 443 | |||
| 444 | # sample metadata |
||
| 445 | sample.metadata <- SampleMetadata(object) |
||
| 446 | |||
| 447 | # get assay id |
||
| 448 | assay_ids <- as.numeric(gsub("Assay", "", rownames(sample.metadata))) |
||
| 449 | assay_id <- paste0("Assay", max(assay_ids)+1) |
||
| 450 | assay_names <- c(rownames(sample.metadata), assay_id) |
||
| 451 | |||
| 452 | # update sample.metadata and metadata |
||
| 453 | object@sample.metadata <- rbind(sample.metadata, c(assay_name, layer, sample)) |
||
| 454 | rownames(object@sample.metadata) <- assay_names |
||
| 455 | object@metadata <- addAssay(object@metadata, metadata = metadata, |
||
| 456 | assay = assay, assay_name = assay_name, |
||
| 457 | sample = sample, layer = layer) |
||
| 458 | |||
| 459 | # get sample and layer |
||
| 460 | curlayer <- object[[sample, layer]] |
||
| 461 | assay_list <- curlayer@assay |
||
| 462 | |||
| 463 | # change assay name and add to the layer |
||
| 464 | vrAssayNames(assay) <- assay_id |
||
| 465 | new_assay_list <- list(assay) |
||
| 466 | names(new_assay_list) <- assay_name |
||
| 467 | assay_list <- c(assay_list, new_assay_list) |
||
| 468 | object[[sample, layer]]@assay <- assay_list |
||
| 469 | |||
| 470 | # add connectivities of assay to the layer |
||
| 471 | catch_connect <- try(slot(curlayer, name = "connectivity"), silent = TRUE) |
||
| 472 | if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ |
||
| 473 | g_assay <- igraph::make_empty_graph(directed = FALSE) + igraph::vertices(vrSpatialPoints(object, assay = assay_id)) |
||
| 474 | g_layer <- curlayer@connectivity + g_assay |
||
| 475 | object[[sample, layer]]@connectivity <- g_layer |
||
| 476 | } |
||
| 477 | |||
| 478 | # return |
||
| 479 | return(object) |
||
| 480 | } |
||
| 481 | |||
| 482 | #' @param assay a vrAssay object |
||
| 483 | #' @param metadata a predefined metadata |
||
| 484 | #' @param assay_name assay name of the new added assay |
||
| 485 | #' @param sample sample name |
||
| 486 | #' @param layer layer name |
||
| 487 | #' |
||
| 488 | #' @rdname addAssay |
||
| 489 | #' @method addAssay VoltRon |
||
| 490 | #' |
||
| 491 | #' @importFrom igraph make_empty_graph add_edges vertices |
||
| 492 | #' |
||
| 493 | #' @export |
||
| 494 | setMethod("addAssay", "VoltRon", addAssayVoltRon) |
||
| 495 | |||
| 496 | vrAssayNamesVoltRon <- function(object, assay = NULL){ |
||
| 497 | |||
| 498 | # sample metadata |
||
| 499 | sample.metadata <- SampleMetadata(object) |
||
| 500 | |||
| 501 | # check assays |
||
| 502 | if(is.null(assay)) |
||
| 503 | assay <- vrMainAssay(object) |
||
| 504 | |||
| 505 | # get assay names |
||
| 506 | if(any(assay == "all")){ |
||
| 507 | assay_names <- rownames(sample.metadata) |
||
| 508 | } else { |
||
| 509 | if(all(assay %in% sample.metadata$Assay)){ |
||
| 510 | assay_names <- rownames(sample.metadata)[sample.metadata$Assay %in% assay] |
||
| 511 | } else { |
||
| 512 | if(all(assay %in% rownames(sample.metadata))) { |
||
| 513 | assay_names <- assay |
||
| 514 | } else { |
||
| 515 | stop("Assay name or type is not found in the object") |
||
| 516 | } |
||
| 517 | } |
||
| 518 | } |
||
| 519 | |||
| 520 | return(assay_names) |
||
| 521 | } |
||
| 522 | |||
| 523 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 524 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 525 | #' |
||
| 526 | #' @rdname vrAssayNames |
||
| 527 | #' @order 2 |
||
| 528 | #' @export |
||
| 529 | setMethod("vrAssayNames", "VoltRon", vrAssayNamesVoltRon) |
||
| 530 | |||
| 531 | vrAssayTypesVoltRon <- function(object, assay = NULL){ |
||
| 532 | |||
| 533 | # get assay names |
||
| 534 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 535 | |||
| 536 | # get assay types |
||
| 537 | assay_types <- vapply(assay_names, function(x) vrAssayTypes(object[[x]]), character(1)) |
||
| 538 | |||
| 539 | return(assay_types) |
||
| 540 | } |
||
| 541 | |||
| 542 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 543 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 544 | #' |
||
| 545 | #' @rdname vrAssayTypes |
||
| 546 | #' @order 2 |
||
| 547 | #' |
||
| 548 | #' @export |
||
| 549 | setMethod("vrAssayTypes", "VoltRon", vrAssayTypesVoltRon) |
||
| 550 | |||
| 551 | changeSampleNamesVoltRon <- function(object, samples = NULL){ |
||
| 552 | |||
| 553 | # sample metadata |
||
| 554 | sample.metadata <- SampleMetadata(object) |
||
| 555 | |||
| 556 | # old to new samples table |
||
| 557 | samples_table <- data.frame(sample.metadata, AssayID = rownames(sample.metadata), NewSample = samples) |
||
| 558 | |||
| 559 | # check if multiple new sample names are associated with the same section of one sample |
||
| 560 | check_samples_table <- samples_table %>% |
||
| 561 | dplyr::group_by(Assay, Sample) %>% dplyr::mutate(n = dplyr::n_distinct(NewSample)) %>% |
||
| 562 | select(c("Assay", "Sample", "n")) %>% distinct() |
||
| 563 | if(any(check_samples_table$n > 1)){ |
||
| 564 | message("Overwriting the sample names of assays that were original from a single layer of a sample aren't allowed") |
||
| 565 | stop("Check Sample Metadata for the correct Sample reassignment") |
||
| 566 | } |
||
| 567 | |||
| 568 | # assign new sample names to samples and sample metadata |
||
| 569 | new_sample.metadata <- NULL |
||
| 570 | new_listofSamples <- list() |
||
| 571 | for(cur_sample in unique(samples)){ |
||
| 572 | |||
| 573 | # current sample and sample table |
||
| 574 | cur_sample.metadata <- samples_table[samples_table$NewSample == cur_sample,] |
||
| 575 | |||
| 576 | # for each unique sample names, combine layers and multiple samples into one |
||
| 577 | listofLayers <- NULL |
||
| 578 | uniq_old_samples <- unique(cur_sample.metadata$Sample) |
||
| 579 | for(i in seq_len(length(uniq_old_samples))){ |
||
| 580 | listofLayers <- c(listofLayers, object[[uniq_old_samples[i]]]@layer) |
||
| 581 | } |
||
| 582 | cur_sample.metadata$comb <- paste(cur_sample.metadata$Sample, cur_sample.metadata$Layer, sep = "_") |
||
| 583 | cur_sample.metadata$NewLayer <- paste0("Section", as.numeric(factor(cur_sample.metadata$comb, levels = unique(cur_sample.metadata$comb)))) |
||
| 584 | # names(listofLayers) <- cur_sample.metadata$NewLayer |
||
| 585 | names(listofLayers) <- unique(cur_sample.metadata$NewLayer) ## CHANGE THIS LATER IF NEEDED #### |
||
| 586 | |||
| 587 | # make layer adjacency and get distance |
||
| 588 | adjacency <- matrix(0, nrow = length(listofLayers), ncol = length(listofLayers), |
||
| 589 | dimnames = list(names(listofLayers), names(listofLayers))) |
||
| 590 | diag(adjacency) <- 1 |
||
| 591 | # distance <- matrix(NA, nrow = length(listofLayers), ncol = length(listofLayers), |
||
| 592 | # dimnames = list(names(listofLayers), names(listofLayers))) |
||
| 593 | # diag(distance) <- 0 |
||
| 594 | zlocation <- rep(0,length(listofLayers)) |
||
| 595 | names(zlocation) <- names(listofLayers) |
||
| 596 | |||
| 597 | # make new block |
||
| 598 | # listofSamples <- list(methods::new("vrBlock", |
||
| 599 | # layer = listofLayers, adjacency = adjacency, distance = distance)) |
||
| 600 | listofSamples <- list(methods::new("vrBlock", |
||
| 601 | layer = listofLayers, zlocation = zlocation, adjacency = adjacency)) |
||
| 602 | names(listofSamples) <- cur_sample |
||
| 603 | new_listofSamples <- c(new_listofSamples, listofSamples) |
||
| 604 | new_sample.metadata <- rbind(new_sample.metadata, cur_sample.metadata) |
||
| 605 | } |
||
| 606 | |||
| 607 | # assign new samples and layers to metadata |
||
| 608 | metadata <- changeSampleNames(Metadata(object, type = "all"), sample_metadata_table = new_sample.metadata) |
||
| 609 | |||
| 610 | # sample metadata |
||
| 611 | new_sample.metadata <- new_sample.metadata[,c("Assay", "NewLayer", "NewSample")] |
||
| 612 | colnames(new_sample.metadata) <- c("Assay", "Layer", "Sample") |
||
| 613 | |||
| 614 | # reinsert object elements |
||
| 615 | object@sample.metadata <- new_sample.metadata |
||
| 616 | object@samples <- new_listofSamples |
||
| 617 | object@metadata <- metadata |
||
| 618 | |||
| 619 | # return |
||
| 620 | return(object) |
||
| 621 | } |
||
| 622 | |||
| 623 | #' changeSampleNames.VoltRon |
||
| 624 | #' |
||
| 625 | #' Change the sample names of the VoltRon object and reorient layers if needed |
||
| 626 | #' |
||
| 627 | #' @param samples a single or a set of sample names |
||
| 628 | #' |
||
| 629 | #' @rdname changeSampleNames |
||
| 630 | #' |
||
| 631 | #' @importFrom dplyr n_distinct %>% distinct select mutate group_by |
||
| 632 | #' @importFrom methods new |
||
| 633 | #' |
||
| 634 | #' @noRd |
||
| 635 | setMethod("changeSampleNames", "VoltRon", changeSampleNamesVoltRon) |
||
| 636 | |||
| 637 | changeAssayNamesVoltRon <- function(object, assays = NULL){ |
||
| 638 | |||
| 639 | # sample metadata |
||
| 640 | sample.metadata <- SampleMetadata(object) |
||
| 641 | |||
| 642 | # check the length of the new assay names |
||
| 643 | if(nrow(sample.metadata) != length(assays)) |
||
| 644 | stop("The set of new assay names should be of the number of assays in the VoltRon object.") |
||
| 645 | |||
| 646 | # check the uniqueness of the assay names |
||
| 647 | if(length(unique(assays)) != length(assays)) |
||
| 648 | stop("Each new assay name should be unique") |
||
| 649 | |||
| 650 | # attach new names of sample.metadata |
||
| 651 | sample.metadata$NewAssayNames <- assays |
||
| 652 | |||
| 653 | # change assay names in layers |
||
| 654 | samples <- unique(sample.metadata$Sample) |
||
| 655 | for(samp in samples){ |
||
| 656 | object[[samp]] <- changeAssayNames(object[[samp]], sample.metadata = sample.metadata[sample.metadata$Sample == samp,]) |
||
| 657 | } |
||
| 658 | |||
| 659 | # return |
||
| 660 | return(object) |
||
| 661 | } |
||
| 662 | |||
| 663 | #' changeAssayNames.VoltRon |
||
| 664 | #' |
||
| 665 | #' Change the sample names of the VoltRon object and reorient layers if needed |
||
| 666 | #' |
||
| 667 | #' @rdname changeAssayNames |
||
| 668 | #' @method changeAssayNames VoltRon |
||
| 669 | #' |
||
| 670 | #' @param object a VoltRon object |
||
| 671 | #' @param assays a set of assay names |
||
| 672 | #' |
||
| 673 | #' @noRd |
||
| 674 | setMethod("changeAssayNames", "VoltRon", changeAssayNamesVoltRon) |
||
| 675 | |||
| 676 | #' addLayerConnectivity |
||
| 677 | #' |
||
| 678 | #' add connectivity information to the assays (vrAssay) of the same layer (vrLayer) |
||
| 679 | #' |
||
| 680 | #' @param object a VoltRon object |
||
| 681 | #' @param connectivity a metadata of edges representing connected spatial points across assays |
||
| 682 | #' @param sample sample name |
||
| 683 | #' @param layer layer name |
||
| 684 | #' |
||
| 685 | #' @importFrom igraph add_edges |
||
| 686 | #' |
||
| 687 | #' @noRd |
||
| 688 | addLayerConnectivity <- function(object, connectivity, sample, layer){ |
||
| 689 | |||
| 690 | # get sample and layer |
||
| 691 | curlayer <- object[[sample, layer]] |
||
| 692 | |||
| 693 | # make edges from connectivity matrix |
||
| 694 | connectivity <- as.vector(t(as.matrix(connectivity))) |
||
| 695 | |||
| 696 | # add edges |
||
| 697 | object[[sample, layer]]@connectivity <- igraph::add_edges(curlayer@connectivity, edges = connectivity) |
||
| 698 | |||
| 699 | # return |
||
| 700 | return(object) |
||
| 701 | } |
||
| 702 | |||
| 703 | ### Layer Methods #### |
||
| 704 | |||
| 705 | #' addBlockConnectivity |
||
| 706 | #' |
||
| 707 | #' add connectivity information to the layers (vrLayer) of the same block (Block) |
||
| 708 | #' |
||
| 709 | #' @param object a VoltRon object |
||
| 710 | #' @param connectivity a metadata of edges representing connected layers within a block |
||
| 711 | #' @param zlocation |
||
| 712 | #' @param sample sample name |
||
| 713 | #' |
||
| 714 | #' @noRd |
||
| 715 | addBlockConnectivity <- function(object, connectivity, zlocation = NULL, sample){ |
||
| 716 | |||
| 717 | # get sample and layer |
||
| 718 | cursample <- object[[sample]] |
||
| 719 | |||
| 720 | # update z location/coordinates |
||
| 721 | if(!is.null(zlocation)){ |
||
| 722 | cursample@zlocation[names(cursample@zlocation)] <- zlocation |
||
| 723 | } |
||
| 724 | |||
| 725 | # update adjacency |
||
| 726 | adjacency <- cursample@adjacency |
||
| 727 | for(i in seq_len(nrow(connectivity))){ |
||
| 728 | adjacency[connectivity[i,1], connectivity[i,2]] <- |
||
| 729 | adjacency[connectivity[i,2], connectivity[i,1]] <- 1 |
||
| 730 | } |
||
| 731 | cursample@adjacency <- adjacency |
||
| 732 | |||
| 733 | # return sample |
||
| 734 | object[[sample]] <- cursample |
||
| 735 | |||
| 736 | # return |
||
| 737 | return(object) |
||
| 738 | } |
||
| 739 | |||
| 740 | #' getBlockConnectivity |
||
| 741 | #' |
||
| 742 | #' get connected assays |
||
| 743 | #' |
||
| 744 | #' @param object a VoltRon object |
||
| 745 | #' @param connectivity a metadata of edges representing connected layers within a block |
||
| 746 | #' @param zlocation |
||
| 747 | #' @param sample sample name |
||
| 748 | #' |
||
| 749 | #' @importFrom igraph components graph_from_adjacency_matrix |
||
| 750 | #' |
||
| 751 | #' @noRd |
||
| 752 | getBlockConnectivity <- function(object, assay){ |
||
| 753 | |||
| 754 | # get assay names |
||
| 755 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 756 | |||
| 757 | # get samples |
||
| 758 | sample_metadata <- SampleMetadata(object) |
||
| 759 | samples <- unique(sample_metadata[assay_names, "Sample"]) |
||
| 760 | |||
| 761 | # get list of connected assays |
||
| 762 | assay_list <- list() |
||
| 763 | for(samp in samples){ |
||
| 764 | cur_sample_metadata <- sample_metadata[sample_metadata$Sample == samp,] |
||
| 765 | cur_assaynames <- assay_names[assay_names %in% rownames(cur_sample_metadata)] |
||
| 766 | cur_sections <- cur_sample_metadata[cur_assaynames, "Layer"] |
||
| 767 | |||
| 768 | catch_connect <- try(slot(object[[samp]], name = "adjacency"), silent = TRUE) |
||
| 769 | if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ |
||
| 770 | adjacency <- object[[samp]]@adjacency |
||
| 771 | adjacency <- adjacency[match(cur_sections,rownames(adjacency)), match(cur_sections,rownames(adjacency)), drop = FALSE] |
||
| 772 | colnames(adjacency) <- rownames(adjacency) <- cur_assaynames |
||
| 773 | components <- igraph::components(igraph::graph_from_adjacency_matrix(adjacency)) |
||
| 774 | assay_list <- c(assay_list, split(names(components$membership), components$membership)) |
||
| 775 | } else { |
||
| 776 | assay_list <- c(assay_list, cur_assaynames) |
||
| 777 | } |
||
| 778 | } |
||
| 779 | |||
| 780 | # return list |
||
| 781 | assay_list |
||
| 782 | } |
||
| 783 | |||
| 784 | ### Object Methods #### |
||
| 785 | |||
| 786 | subsetVoltRon <- function(x, subset, samples = NULL, assays = NULL, spatialpoints = NULL, features = NULL, image = NULL, interactive = FALSE, use.points.only = FALSE, |
||
| 787 | shiny.options = list(launch.browser = getOption("shiny.launch.browser", interactive()))) { |
||
| 788 | |||
| 789 | # start |
||
| 790 | object <- x |
||
| 791 | |||
| 792 | # subseting based on subset argument |
||
| 793 | if (!missing(x = subset)) { |
||
| 794 | # subset_data <- subset |
||
| 795 | subset <- rlang::enquo(arg = subset) |
||
| 796 | } |
||
| 797 | if(!missing(subset)){ |
||
| 798 | metadata <- Metadata(object) |
||
| 799 | name <- strsplit(rlang::quo_text(subset), split = " ")[[1]][1] |
||
| 800 | if(name %in% colnames(metadata)){ |
||
| 801 | if(inherits(metadata, "data.table")){ |
||
| 802 | spatialpoints <- metadata$id[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] |
||
| 803 | } else if(inherits(metadata, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))){ |
||
| 804 | stop("Direct subsetting for Ondisk VoltRon objects are currently not possible!") |
||
| 805 | # spatialpoints <- as.vector(metadata$id)[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] |
||
| 806 | } else { |
||
| 807 | if(!is.null(rownames(metadata))){ |
||
| 808 | cur_data <- rownames(metadata) |
||
| 809 | } else { |
||
| 810 | cur_data <- metadata$id |
||
| 811 | } |
||
| 812 | spatialpoints <- rownames(metadata)[eval_tidy(rlang::quo_get_expr(subset), data = metadata)] |
||
| 813 | } |
||
| 814 | } else { |
||
| 815 | stop("Column '", name, "' is not found in the metadata") |
||
| 816 | } |
||
| 817 | object <- subsetVoltRon(object, spatialpoints = spatialpoints) |
||
| 818 | return(object) |
||
| 819 | } |
||
| 820 | |||
| 821 | # subseting on other attributes |
||
| 822 | attrinfo <- c(vapply(list(samples, assays, spatialpoints, features), function(x) length(x) > 0, logical(1)), interactive) |
||
| 823 | if(sum(attrinfo) > 1){ |
||
| 824 | stop("Please choose only one of the subsetting attributes: 'samples', 'assays', 'spatialpoints', 'features' or 'interactive'") |
||
| 825 | } |
||
| 826 | |||
| 827 | # sample metadata |
||
| 828 | sample.metadata <- SampleMetadata(object) |
||
| 829 | |||
| 830 | # subsetting |
||
| 831 | if(!is.null(samples)){ |
||
| 832 | |||
| 833 | # check assays associated with samples and subset for assays |
||
| 834 | if(all(samples %in% sample.metadata$Sample)){ |
||
| 835 | assays <- rownames(sample.metadata)[sample.metadata$Sample %in% samples] |
||
| 836 | # return(subset.VoltRon(object, assays = assays)) |
||
| 837 | return(subsetVoltRon(object, assays = assays)) |
||
| 838 | } else { |
||
| 839 | stop("Some requested samples are not found in this VoltRon object!") |
||
| 840 | } |
||
| 841 | |||
| 842 | } else if(!is.null(assays)){ |
||
| 843 | |||
| 844 | # subset for assays |
||
| 845 | sample.metadata <- subset_sampleMetadata(sample.metadata, assays = assays) |
||
| 846 | # metadata <- subset.vrMetadata(Metadata(object, type = "all"), assays = assays) |
||
| 847 | metadata <- subsetvrMetadata(Metadata(object, type = "all"), assays = assays) |
||
| 848 | samples <- unique(sample.metadata$Sample) |
||
| 849 | listofSamples <- sapply(object@samples[samples], function(samp) { |
||
| 850 | # subset.vrSample(samp, assays = assays) |
||
| 851 | subsetvrSample(samp, assays = assays) |
||
| 852 | }, USE.NAMES = TRUE) |
||
| 853 | |||
| 854 | } else if(!is.null(spatialpoints)) { |
||
| 855 | |||
| 856 | # subsetting on entity names |
||
| 857 | # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 858 | metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 859 | samples <- vrSampleNames(metadata) |
||
| 860 | listofSamples <- sapply(object@samples[samples], function(samp) { |
||
| 861 | subsetvrSample(samp, spatialpoints = spatialpoints) |
||
| 862 | }, USE.NAMES = TRUE) |
||
| 863 | # spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints.vrSample)) |
||
| 864 | spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints)) |
||
| 865 | # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 866 | metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 867 | sample.metadata <- subset_sampleMetadata(sample.metadata, assays = vrAssayNamesvrMetadata(metadata)) |
||
| 868 | |||
| 869 | } else if(!is.null(features)){ |
||
| 870 | |||
| 871 | # subsetting on features |
||
| 872 | assay_names <- vrAssayNames(object) |
||
| 873 | for(assy in assay_names){ |
||
| 874 | if(inherits(object[[assy]], "vrAssay")){ |
||
| 875 | # object[[assy]] <- subset.vrAssay(object[[assy]], features = features) |
||
| 876 | object[[assy]] <- subsetvrAssay(object[[assy]], features = features) |
||
| 877 | } else { |
||
| 878 | # object[[assy]] <- subset.vrAssayV2(object[[assy]], features = features) |
||
| 879 | object[[assy]] <- subsetvrAssay(object[[assy]], features = features) |
||
| 880 | } |
||
| 881 | } |
||
| 882 | metadata <- Metadata(object, type = "all") |
||
| 883 | listofSamples <- object@samples |
||
| 884 | |||
| 885 | } else if(!is.null(image)) { |
||
| 886 | |||
| 887 | # subsetting on image |
||
| 888 | if(inherits(image, "character")){ |
||
| 889 | |||
| 890 | # check if there are only one image and one assay |
||
| 891 | numlayers <- paste0(sample.metadata$Layer, sample.metadata$Sample) |
||
| 892 | if(length(unique(numlayers)) > 1){ |
||
| 893 | stop("Subseting on images can only be performed on VoltRon objects with a single layer") |
||
| 894 | } else { |
||
| 895 | samples <- unique(sample.metadata$Sample) |
||
| 896 | listofSamples <- sapply(object@samples[samples], function(samp) { |
||
| 897 | subsetvrSample(samp, image = image) |
||
| 898 | }, USE.NAMES = TRUE) |
||
| 899 | # spatialpoints <- do.call(c, lapply(listofSamples, vrSpatialPoints.vrSample)) |
||
| 900 | spatialpoints <- do.call("c", lapply(listofSamples, vrSpatialPoints)) |
||
| 901 | # metadata <- subset.vrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 902 | metadata <- subsetvrMetadata(Metadata(object, type = "all"), spatialpoints = spatialpoints) |
||
| 903 | } |
||
| 904 | } else { |
||
| 905 | stop("Please provide a character based subsetting notation, see magick::image_crop documentation") |
||
| 906 | } |
||
| 907 | } else if(interactive){ |
||
| 908 | |||
| 909 | # interactive subsetting |
||
| 910 | results <- demuxVoltRon(object, use.points.only = use.points.only, shiny.options = shiny.options) |
||
| 911 | return(results) |
||
| 912 | } |
||
| 913 | |||
| 914 | # main.assay |
||
| 915 | main.assay <- unique(sample.metadata$Assay)[unique(sample.metadata$Assay) == names(table(sample.metadata$Assay))[which.max(table(sample.metadata$Assay))]] |
||
| 916 | |||
| 917 | # project |
||
| 918 | project <- object@project |
||
| 919 | |||
| 920 | # subset graphs |
||
| 921 | graph_list <- subset_graphs(object, |
||
| 922 | spatialpoints = vrSpatialPoints(metadata, assay = vrAssayNames(object))) |
||
| 923 | |||
| 924 | # set VoltRon class |
||
| 925 | methods::new("VoltRon", |
||
| 926 | samples = listofSamples, metadata = metadata, sample.metadata = sample.metadata, |
||
| 927 | graph = graph_list, main.assay = main.assay, project = project) |
||
| 928 | } |
||
| 929 | |||
| 930 | #' Subsetting VoltRon objects |
||
| 931 | #' |
||
| 932 | #' Given a VoltRon object, subset the object given one of the attributes |
||
| 933 | #' |
||
| 934 | #' @param x a VoltRon object |
||
| 935 | #' @param subset Logical statement for subsetting |
||
| 936 | #' @param samples the set of samples to subset the object |
||
| 937 | #' @param assays the set of assays to subset the object |
||
| 938 | #' @param spatialpoints the set of spatial points to subset the object |
||
| 939 | #' @param features the set of features to subset the object |
||
| 940 | #' @param image the subseting string passed to \link{image_crop} |
||
| 941 | #' @param interactive TRUE if interactive subsetting on the image is demanded |
||
| 942 | #' @param use.points.only if \code{interactive} is \code{TRUE}, use spatial points instead of the reference image |
||
| 943 | #' @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} |
||
| 944 | #' |
||
| 945 | #' @rdname subset |
||
| 946 | #' @aliases subset |
||
| 947 | #' @method subset VoltRon |
||
| 948 | #' |
||
| 949 | #' @importFrom rlang enquo eval_tidy quo_get_expr quo_text |
||
| 950 | #' @importFrom stringr str_extract |
||
| 951 | #' @importFrom methods new |
||
| 952 | #' |
||
| 953 | #' @export |
||
| 954 | #' |
||
| 955 | #' @examples |
||
| 956 | #' # example data |
||
| 957 | #' data("visium_data") |
||
| 958 | #' |
||
| 959 | #' # subset based on assay |
||
| 960 | #' subset(visium_data, assays = "Assay1") |
||
| 961 | #' subset(visium_data, assays = "Visium") |
||
| 962 | #' |
||
| 963 | #' # subset based on samples |
||
| 964 | #' subset(visium_data, samples = "Anterior1") |
||
| 965 | #' |
||
| 966 | #' # subset based on assay |
||
| 967 | #' subset(visium_data, spatialpoints = c("GTTATATTATCTCCCT-1_Assay1", "GTTTGGGTTTCGCCCG-1_Assay1")) |
||
| 968 | #' |
||
| 969 | #' # subset based on features |
||
| 970 | #' subset(visium_data, features = c("Map3k19", "Rab3gap1")) |
||
| 971 | #' |
||
| 972 | #' # interactive subsetting |
||
| 973 | #' \dontrun{ |
||
| 974 | #' visium_subset_data <- subset(visium_data, interactive = TRUE) |
||
| 975 | #' visium_subset <- visium_subset_data$subsets[[1]] |
||
| 976 | #' } |
||
| 977 | setMethod("subset", "VoltRon", subsetVoltRon) |
||
| 978 | |||
| 979 | mergeVoltRon <- function(x, y, samples = NULL, main.assay = NULL, verbose = TRUE) { |
||
| 980 | |||
| 981 | # start |
||
| 982 | object <- x |
||
| 983 | object_list <- y |
||
| 984 | |||
| 985 | # combine all elements |
||
| 986 | if(!is.list(object_list)) |
||
| 987 | object_list <- list(object_list) |
||
| 988 | object_list <- c(object, object_list) |
||
| 989 | |||
| 990 | # check if all are VoltRon |
||
| 991 | if(!all(lapply(object_list, class) == "VoltRon")) |
||
| 992 | stop("All arguements have to be of VoltRon class") |
||
| 993 | |||
| 994 | # sample metadata list |
||
| 995 | sample.metadata_list <- lapply(object_list, function(x) slot(x, name = "sample.metadata")) |
||
| 996 | |||
| 997 | # old assay names |
||
| 998 | old_assay_names <- do.call(c, lapply(sample.metadata_list, rownames)) |
||
| 999 | |||
| 1000 | # merge sample metadata |
||
| 1001 | sample.metadata <- merge_sampleMetadata(sample.metadata_list) |
||
| 1002 | |||
| 1003 | # merge metadata and sample metadata |
||
| 1004 | if(verbose) |
||
| 1005 | message("Merging metadata ...") |
||
| 1006 | metadata_list <- lapply(object_list, function(x) slot(x, name = "metadata")) |
||
| 1007 | metadata <- mergevrMetadata(metadata_list[[1]], metadata_list[-1]) |
||
| 1008 | |||
| 1009 | # combine samples and rename layers |
||
| 1010 | if(verbose) |
||
| 1011 | message("Merging blocks and layers ...") |
||
| 1012 | listofSamples <- NULL |
||
| 1013 | for(i in seq_len(length(object_list))){ |
||
| 1014 | cur_object <- object_list[[i]]@samples |
||
| 1015 | listofSamples <- c(listofSamples, cur_object) |
||
| 1016 | } |
||
| 1017 | |||
| 1018 | # get main assay |
||
| 1019 | if(is.null(main.assay)) |
||
| 1020 | main.assay <- names(sort(table(sample.metadata$Assay), decreasing = TRUE))[1] |
||
| 1021 | |||
| 1022 | # project |
||
| 1023 | project <- slot(object_list[[1]], "project") |
||
| 1024 | |||
| 1025 | # set VoltRon class |
||
| 1026 | object <- methods::new("VoltRon", samples = listofSamples, metadata = metadata, sample.metadata = sample.metadata, main.assay = main.assay, project = project) |
||
| 1027 | |||
| 1028 | # change assay names and sample names |
||
| 1029 | object <- changeAssayNames(object, assays = rownames(sample.metadata)) |
||
| 1030 | |||
| 1031 | # change sample names |
||
| 1032 | if(!is.null(samples)) |
||
| 1033 | object$Sample <- samples |
||
| 1034 | |||
| 1035 | # return |
||
| 1036 | object |
||
| 1037 | } |
||
| 1038 | |||
| 1039 | #' Merging VoltRon objects |
||
| 1040 | #' |
||
| 1041 | #' Given a VoltRon object, and a list of VoltRon objects, merge all. |
||
| 1042 | #' |
||
| 1043 | #' @param x a VoltRon Object |
||
| 1044 | #' @param y a single or a list of VoltRon objects |
||
| 1045 | #' @param samples a single sample name or multiple sample names of the same size as the given VoltRon objects |
||
| 1046 | #' @param main.assay the name of the main assay |
||
| 1047 | #' @param verbose verbose |
||
| 1048 | #' |
||
| 1049 | #' @rdname merge |
||
| 1050 | #' @aliases merge |
||
| 1051 | #' @method merge VoltRon |
||
| 1052 | #' @importFrom methods new |
||
| 1053 | #' |
||
| 1054 | #' @export |
||
| 1055 | setMethod("merge", signature = "VoltRon", mergeVoltRon) |
||
| 1056 | |||
| 1057 | #' @rdname vrSpatialPoints |
||
| 1058 | #' @order 2 |
||
| 1059 | #' |
||
| 1060 | #' @export |
||
| 1061 | setMethod("vrSpatialPoints", "VoltRon", function(object, assay = NULL) { |
||
| 1062 | |||
| 1063 | # get assays |
||
| 1064 | assay <- vrAssayNames(object, assay = assay) |
||
| 1065 | |||
| 1066 | # return |
||
| 1067 | return(vrSpatialPoints(object@metadata, assay = assay)) |
||
| 1068 | }) |
||
| 1069 | |||
| 1070 | vrFeaturesVoltRon <- function(object, assay = NULL) { |
||
| 1071 | |||
| 1072 | # get assay names |
||
| 1073 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1074 | |||
| 1075 | # get all features |
||
| 1076 | features <- NULL |
||
| 1077 | for(assy in assay_names) |
||
| 1078 | features <- c(features, vrFeatures(object[[assy]])) |
||
| 1079 | |||
| 1080 | return(unique(features)) |
||
| 1081 | } |
||
| 1082 | |||
| 1083 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1084 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1085 | #' |
||
| 1086 | #' @rdname vrFeatures |
||
| 1087 | #' @method vrFeatures VoltRon |
||
| 1088 | #' @order 2 |
||
| 1089 | #' @export |
||
| 1090 | setMethod("vrFeatures", "VoltRon", vrFeaturesVoltRon) |
||
| 1091 | |||
| 1092 | vrFeatureDataVoltRon <- function(object, assay = NULL, feat_type = NULL) { |
||
| 1093 | |||
| 1094 | # get assay names |
||
| 1095 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1096 | |||
| 1097 | # get all features |
||
| 1098 | features <- vrFeatureData(object[[assay_names[1]]], feat_type = feat_type) |
||
| 1099 | |||
| 1100 | # return |
||
| 1101 | return(features) |
||
| 1102 | } |
||
| 1103 | |||
| 1104 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1105 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1106 | #' |
||
| 1107 | #' @rdname vrFeatureData |
||
| 1108 | #' @order 2 |
||
| 1109 | #' @export |
||
| 1110 | setMethod("vrFeatureData", "VoltRon", vrFeatureDataVoltRon) |
||
| 1111 | |||
| 1112 | vrFeatureDataReplaceVoltRon <- function(object, assay = NULL, value) { |
||
| 1113 | |||
| 1114 | # get assay names |
||
| 1115 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1116 | |||
| 1117 | # set embeddings |
||
| 1118 | for(assy in assay_names) |
||
| 1119 | vrFeatureData(object[[assy]]) <- value |
||
| 1120 | |||
| 1121 | return(object) |
||
| 1122 | } |
||
| 1123 | |||
| 1124 | #' @param value new feature metadata |
||
| 1125 | #' |
||
| 1126 | #' @rdname vrFeatureData |
||
| 1127 | #' @order 4 |
||
| 1128 | #' @export |
||
| 1129 | setMethod("vrFeatureData<-", "VoltRon", vrFeatureDataReplaceVoltRon) |
||
| 1130 | |||
| 1131 | vrDataVoltRon <- function(object, assay = NULL, features = NULL, feat_type = NULL, norm = FALSE, ...) { |
||
| 1132 | |||
| 1133 | # get assay names |
||
| 1134 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1135 | |||
| 1136 | # get all coordinates |
||
| 1137 | data <- NULL |
||
| 1138 | for(i in seq_len(length(assay_names))){ |
||
| 1139 | cur_data <- vrData(object[[assay_names[i]]], features = features, feat_type = feat_type, norm = norm, ...) |
||
| 1140 | if(inherits(cur_data, c("dgCMatrix", "CsparseMatrix", "dsparseMatrix"))){ |
||
| 1141 | cur_data <- as.matrix(cur_data) |
||
| 1142 | } |
||
| 1143 | if(inherits(cur_data, c("data.frame", "Matrix", "matrix"))){ |
||
| 1144 | cur_data <- data.frame(cur_data, feature.ID = rownames(cur_data), check.names = FALSE) |
||
| 1145 | } |
||
| 1146 | if(i == 1){ |
||
| 1147 | data <- cur_data |
||
| 1148 | } else { |
||
| 1149 | data <- merge_data(data, cur_data, by = "feature.ID") |
||
| 1150 | } |
||
| 1151 | } |
||
| 1152 | if("feature.ID" %in% colnames(data)){ |
||
| 1153 | rownames(data) <- data$feature.ID |
||
| 1154 | data <- data[,!colnames(data) %in% "feature.ID"] |
||
| 1155 | data <- as.matrix(data) |
||
| 1156 | data <- replaceNaMatrix(data, 0) |
||
| 1157 | colnames(data) <- gsub("\\.","-", colnames(data)) |
||
| 1158 | } |
||
| 1159 | |||
| 1160 | return(data) |
||
| 1161 | } |
||
| 1162 | |||
| 1163 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1164 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1165 | #' @param features the set of features |
||
| 1166 | #' @param feat_type the feature set type |
||
| 1167 | #' @param norm TRUE if normalized data should be returned |
||
| 1168 | #' @param ... additional parameters passed to other methods and \link{vrImages} |
||
| 1169 | #' |
||
| 1170 | #' @rdname vrData |
||
| 1171 | #' @order 2 |
||
| 1172 | #' |
||
| 1173 | #' @importFrom dplyr full_join mutate_all coalesce |
||
| 1174 | #' |
||
| 1175 | #' @export |
||
| 1176 | setMethod("vrData", "VoltRon", vrDataVoltRon) |
||
| 1177 | |||
| 1178 | #' @importFrom Matrix Matrix |
||
| 1179 | merge_data <- function(data1, data2, by = "feature.ID"){ |
||
| 1180 | if(inherits(data1, c("data.frame", "Matrix"))){ |
||
| 1181 | |||
| 1182 | # merge |
||
| 1183 | data1 <- dplyr::full_join(data1, data2, by = "feature.ID") |
||
| 1184 | |||
| 1185 | } else if(inherits(data1, c("IterableMatrix"))) { |
||
| 1186 | rownames_all <- unique(c(rownames(data1), rownames(data2))) |
||
| 1187 | |||
| 1188 | # first data |
||
| 1189 | m <- Matrix::Matrix(nrow = length(rownames_all) - length(rownames(data1)), ncol = ncol(data1), data = 0, sparse = TRUE) |
||
| 1190 | data1_new <- rbind(data1, m) |
||
| 1191 | rownames(data1_new) <- c(rownames(data1), setdiff(rownames_all, rownames(data1))) |
||
| 1192 | data1_new <- data1_new[rownames_all,] |
||
| 1193 | |||
| 1194 | # second data |
||
| 1195 | m <- Matrix::Matrix(nrow = length(rownames_all) - length(rownames(data2)), ncol = ncol(data2), data = 0, sparse = TRUE) |
||
| 1196 | data2_new <- rbind(data2, m) |
||
| 1197 | rownames(data2_new) <- c(rownames(data2), setdiff(rownames_all, rownames(data2))) |
||
| 1198 | data2_new <- data2_new[rownames_all,] |
||
| 1199 | |||
| 1200 | # merge |
||
| 1201 | data1 <- cbind(data1_new, data2_new) |
||
| 1202 | } |
||
| 1203 | return(data1) |
||
| 1204 | } |
||
| 1205 | |||
| 1206 | generateTileDataVoltRon <- function(object, assay = NULL, ...) { |
||
| 1207 | |||
| 1208 | # get assay names |
||
| 1209 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1210 | |||
| 1211 | # check if assay types are all tiles |
||
| 1212 | assay_types <- vrAssayTypes(object, assay = assay) |
||
| 1213 | if(!all(assay_types == "tile")) |
||
| 1214 | stop("generateTileData can only be used for tile-based assays") |
||
| 1215 | |||
| 1216 | # get tile data for all assays |
||
| 1217 | for(assy in assay_names) |
||
| 1218 | object[[assy]] <- generateTileData(object[[assy]], ...) |
||
| 1219 | } |
||
| 1220 | |||
| 1221 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1222 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1223 | #' @param ... additional parameters passed to vrAssay. |
||
| 1224 | #' |
||
| 1225 | #' @rdname generateTileData |
||
| 1226 | #' @order 2 |
||
| 1227 | #' |
||
| 1228 | #' @export |
||
| 1229 | setMethod("generateTileData", "VoltRon", generateTileDataVoltRon) |
||
| 1230 | |||
| 1231 | vrEmbeddingsVoltRon <- function(object, assay = NULL, type = "pca", dims = seq_len(30)) { |
||
| 1232 | |||
| 1233 | # get assay names |
||
| 1234 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1235 | |||
| 1236 | # get all coordinates |
||
| 1237 | returndata_list <- list() |
||
| 1238 | for(i in seq_len(length(assay_names))) |
||
| 1239 | returndata_list[[i]] <- vrEmbeddings(object[[assay_names[i]]], type = type, dims = dims) |
||
| 1240 | |||
| 1241 | return(do.call(rbind, returndata_list)) |
||
| 1242 | } |
||
| 1243 | |||
| 1244 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1245 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1246 | #' @param type the key name for the embedding, i.e. "pca" or "umap" |
||
| 1247 | #' @param dims the set of dimensions of the embedding data |
||
| 1248 | #' |
||
| 1249 | #' @rdname vrEmbeddings |
||
| 1250 | #' @order 2 |
||
| 1251 | #' |
||
| 1252 | #' @export |
||
| 1253 | setMethod("vrEmbeddings", "VoltRon", vrEmbeddingsVoltRon) |
||
| 1254 | |||
| 1255 | vrEmbeddingsReplaceVoltRon <- function(object, assay = NULL, type = "pca", overwrite = FALSE, value) { |
||
| 1256 | |||
| 1257 | # check if the embedding exists |
||
| 1258 | if(type %in% vrEmbeddingNames(object) && !overwrite) |
||
| 1259 | stop("An embedding named '", type, "' already exists in this object. Do overwrite = TRUE for replacing with the existing one.") |
||
| 1260 | |||
| 1261 | # get assay names |
||
| 1262 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1263 | |||
| 1264 | # set embeddings |
||
| 1265 | for(assy in assay_names){ |
||
| 1266 | assayobject <- object[[assy]] |
||
| 1267 | if(vrAssayTypes(assayobject) %in% c("ROI", "cell", "spot")){ |
||
| 1268 | vrEmbeddings(assayobject, type = type) <- value[grepl(paste0(assy, "$"), rownames(value)),, drop = FALSE] |
||
| 1269 | } else { |
||
| 1270 | vrEmbeddings(assayobject, type = type) <- value[vrSpatialPoints(assayobject),, drop = FALSE] |
||
| 1271 | } |
||
| 1272 | object[[assy]] <- assayobject |
||
| 1273 | } |
||
| 1274 | |||
| 1275 | return(object) |
||
| 1276 | } |
||
| 1277 | |||
| 1278 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1279 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1280 | #' @param type the key name for the embedding |
||
| 1281 | #' @param overwrite Whether the existing embedding with name 'type' should be overwritten |
||
| 1282 | #' @param value new embedding data |
||
| 1283 | #' |
||
| 1284 | #' @rdname vrEmbeddings |
||
| 1285 | #' @order 4 |
||
| 1286 | #' |
||
| 1287 | #' @export |
||
| 1288 | setMethod("vrEmbeddings<-", "VoltRon", vrEmbeddingsReplaceVoltRon) |
||
| 1289 | |||
| 1290 | vrEmbeddingNamesVoltRon <- function(object, assay = NULL){ |
||
| 1291 | |||
| 1292 | # get assay names |
||
| 1293 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1294 | |||
| 1295 | # get assay types |
||
| 1296 | embed_names <- unique(unlist(lapply(assay_names, function(x) vrEmbeddingNames(object[[x]])))) |
||
| 1297 | |||
| 1298 | return(embed_names) |
||
| 1299 | } |
||
| 1300 | |||
| 1301 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1302 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1303 | #' |
||
| 1304 | #' @rdname vrEmbeddingNames |
||
| 1305 | #' @order 2 |
||
| 1306 | #' |
||
| 1307 | #' @export |
||
| 1308 | setMethod("vrEmbeddingNames", "VoltRon", vrEmbeddingNamesVoltRon) |
||
| 1309 | |||
| 1310 | #### Feature #### |
||
| 1311 | |||
| 1312 | addFeatureVoltRon <- function(object, assay = NULL, data, feature_name){ |
||
| 1313 | |||
| 1314 | # get assay names |
||
| 1315 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1316 | if(length(assay_names) > 1){ |
||
| 1317 | stop("You cannot add new features to multiple assays at once!") |
||
| 1318 | } |
||
| 1319 | |||
| 1320 | # add assay |
||
| 1321 | object[[assay_names]] <- addFeature(object[[assay_names]], data = data, feature_name = feature_name) |
||
| 1322 | |||
| 1323 | # return |
||
| 1324 | return(object) |
||
| 1325 | } |
||
| 1326 | |||
| 1327 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1328 | #' 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. |
||
| 1329 | #' @param data new data matrix for new feature set |
||
| 1330 | #' @param feature_name the name of the new feature set |
||
| 1331 | #' |
||
| 1332 | #' @rdname addFeature |
||
| 1333 | #' @method addFeature VoltRon |
||
| 1334 | #' |
||
| 1335 | #' @importFrom stringr str_replace |
||
| 1336 | #' |
||
| 1337 | #' @export |
||
| 1338 | setMethod("addFeature", "VoltRon", addFeatureVoltRon) |
||
| 1339 | |||
| 1340 | vrMainFeatureTypeVoltRon <- function(object, assay = NULL){ |
||
| 1341 | |||
| 1342 | # get assay names |
||
| 1343 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1344 | |||
| 1345 | # if assay = all, give a summary |
||
| 1346 | if(!is.null(assay)){ |
||
| 1347 | if(assay == "all"){ |
||
| 1348 | featuretype_names <- unlist(lapply(rownames(SampleMetadata(object)), function(x) paste(vrMainFeatureType(object[[x]]), collapse = ","))) |
||
| 1349 | featuretype_names <- data.frame(Assay = assay_names, Feature = featuretype_names) |
||
| 1350 | return(featuretype_names) |
||
| 1351 | } |
||
| 1352 | } |
||
| 1353 | |||
| 1354 | # get assay types |
||
| 1355 | featuretype_names <- unlist(lapply(assay_names, function(x) vrMainFeatureType(object[[x]]))) |
||
| 1356 | |||
| 1357 | # return data |
||
| 1358 | if(!is.null(featuretype_names)){ |
||
| 1359 | featuretype_data <- data.frame(Assay = assay_names, Feature = featuretype_names) |
||
| 1360 | return(featuretype_data) |
||
| 1361 | } else { |
||
| 1362 | return(NULL) |
||
| 1363 | } |
||
| 1364 | } |
||
| 1365 | |||
| 1366 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1367 | #' 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. |
||
| 1368 | #' |
||
| 1369 | #' @rdname vrMainFeatureType |
||
| 1370 | #' @order 2 |
||
| 1371 | #' @export |
||
| 1372 | setMethod("vrMainFeatureType", "VoltRon", vrMainFeatureTypeVoltRon) |
||
| 1373 | |||
| 1374 | vrMainFeatureTypeReplaceVoltRon <- function(object, assay = NULL, value){ |
||
| 1375 | |||
| 1376 | # sample metadata |
||
| 1377 | sample_metadata <- SampleMetadata(object) |
||
| 1378 | |||
| 1379 | # assays |
||
| 1380 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1381 | unique_assays <- unique(sample_metadata[assay_names, "Assay"]) |
||
| 1382 | if(length(unique_assays) > 1){ |
||
| 1383 | stop("You can only set the main feature type of a single assay type") |
||
| 1384 | } else { |
||
| 1385 | for(assy in assay_names){ |
||
| 1386 | vrMainFeatureType(object[[assy]], ignore = TRUE) <- value |
||
| 1387 | } |
||
| 1388 | } |
||
| 1389 | |||
| 1390 | return(object) |
||
| 1391 | } |
||
| 1392 | |||
| 1393 | #' @rdname vrMainFeatureType |
||
| 1394 | #' @order 4 |
||
| 1395 | #' @export |
||
| 1396 | setMethod("vrMainFeatureType<-", "VoltRon", vrMainFeatureTypeReplaceVoltRon) |
||
| 1397 | |||
| 1398 | vrFeatureTypeNamesVoltRon <- function(object, assay = NULL){ |
||
| 1399 | |||
| 1400 | # get assay names |
||
| 1401 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1402 | |||
| 1403 | # if assay = all, give a summary |
||
| 1404 | if(!is.null(assay)){ |
||
| 1405 | if(assay == "all"){ |
||
| 1406 | feature_names <- unlist(lapply(assay_names, function(x) paste(vrFeatureTypeNames(object[[x]]), collapse = ","))) |
||
| 1407 | feature_names <- data.frame(Assay = assay_names, Feature = feature_names) |
||
| 1408 | return(feature_names) |
||
| 1409 | } |
||
| 1410 | } |
||
| 1411 | |||
| 1412 | feature_names <- unique(unlist(lapply(assay_names, function(x) vrFeatureTypeNames(object[[x]])))) |
||
| 1413 | |||
| 1414 | return(feature_names) |
||
| 1415 | } |
||
| 1416 | |||
| 1417 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1418 | #' 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 |
||
| 1419 | #' |
||
| 1420 | #' @rdname vrFeatureTypeNames |
||
| 1421 | #' |
||
| 1422 | #' @export |
||
| 1423 | setMethod("vrFeatureTypeNames", "VoltRon", vrFeatureTypeNamesVoltRon) |
||
| 1424 | |||
| 1425 | #### Metadata #### |
||
| 1426 | |||
| 1427 | MetadataVoltRon <- function(object, assay = NULL, type = NULL){ |
||
| 1428 | |||
| 1429 | # check type |
||
| 1430 | if(!is.null(type)){ |
||
| 1431 | |||
| 1432 | if(type == "all"){ |
||
| 1433 | return(object@metadata) |
||
| 1434 | } else { |
||
| 1435 | if(!is.null(assay)){ |
||
| 1436 | stop("Please specify either assay or type, not both!") |
||
| 1437 | } |
||
| 1438 | if(type %in% methods::slotNames(object@metadata)){ |
||
| 1439 | return(slot(object@metadata, name = type)) |
||
| 1440 | } |
||
| 1441 | } |
||
| 1442 | } else{ |
||
| 1443 | type <- unique(vrAssayTypes(object, assay = assay)) |
||
| 1444 | if(length(type) > 1) |
||
| 1445 | stop("You cannot get the metadata of multiple spatial entity types in the same time! See SampleMetadata()") |
||
| 1446 | } |
||
| 1447 | |||
| 1448 | # get assay metadata from matching type |
||
| 1449 | if(type %in% methods::slotNames(object@metadata)){ |
||
| 1450 | |||
| 1451 | # sample metadata |
||
| 1452 | sample.metadata <- SampleMetadata(object) |
||
| 1453 | |||
| 1454 | # get assay names |
||
| 1455 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1456 | |||
| 1457 | # get metadata |
||
| 1458 | metadata <- slot(object@metadata, name = type) |
||
| 1459 | if(inherits(metadata, "data.table")){ |
||
| 1460 | metadata <- subset(metadata, assay_id %in% assay_names) |
||
| 1461 | } else if(inherits(metadata, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))){ |
||
| 1462 | if("assay_id" %in% colnames(metadata)){ |
||
| 1463 | metadata_list <- list() |
||
| 1464 | for(assy in assay_names){ |
||
| 1465 | metadata_list[[assy]] <- metadata[metadata$assay_id == assy,] |
||
| 1466 | } |
||
| 1467 | metadata <- do.call("rbind", metadata_list) |
||
| 1468 | } else { |
||
| 1469 | ind <- stringr::str_extract(as.vector(metadata$id), "Assay[0-9]+") %in% assay_names |
||
| 1470 | metadata <- metadata[ind,] |
||
| 1471 | } |
||
| 1472 | } else { |
||
| 1473 | metadata <- metadata[stringr::str_extract(rownames(metadata), "Assay[0-9]+") %in% assay_names, ] |
||
| 1474 | } |
||
| 1475 | return(metadata) |
||
| 1476 | } else { |
||
| 1477 | stop("Please provide one of five assay types: 'ROI', 'cell', 'spot', 'molecule' or 'tile'.") |
||
| 1478 | } |
||
| 1479 | } |
||
| 1480 | |||
| 1481 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1482 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1483 | #' @param type the assay type: ROI, spot or cell, or all for the entire metadata object |
||
| 1484 | #' |
||
| 1485 | #' @rdname Metadata |
||
| 1486 | #' |
||
| 1487 | #' @importFrom methods slotNames |
||
| 1488 | #' @export |
||
| 1489 | setMethod("Metadata", "VoltRon", MetadataVoltRon) |
||
| 1490 | |||
| 1491 | MetadataReplaceVoltRon <- function(object, assay = NULL, type = NULL, value) { |
||
| 1492 | |||
| 1493 | if(!is.data.frame(value) && !inherits(value, c("HDF5DataFrame", "ZarrDataFrame", "DataFrame"))) |
||
| 1494 | stop("The new or updated metadata has to be a data frame") |
||
| 1495 | |||
| 1496 | `%notin%` <- Negate(`%in%`) |
||
| 1497 | if(is.null(rownames(value)) && "id" %notin% colnames(value)) |
||
| 1498 | stop("The new metadata should have row names or a column called 'id' to match its rows with the existing one") |
||
| 1499 | |||
| 1500 | if(is.null(type)){ |
||
| 1501 | type <- unique(vrAssayTypes(object, assay = assay)) |
||
| 1502 | } |
||
| 1503 | |||
| 1504 | # sample metadata |
||
| 1505 | sample.metadata <- SampleMetadata(object) |
||
| 1506 | |||
| 1507 | # get assay names |
||
| 1508 | # assay_names <- vrAssayNames(object, assay = assay) |
||
| 1509 | |||
| 1510 | # get metadata |
||
| 1511 | metadata <- slot(object@metadata, name = type) |
||
| 1512 | |||
| 1513 | if("id" %in% colnames(metadata)){ |
||
| 1514 | |||
| 1515 | # replace the metadata (or some part of it) with the new value |
||
| 1516 | if(length(setdiff(value$id, metadata$id)) == 0){ |
||
| 1517 | |||
| 1518 | # check columns of the new table |
||
| 1519 | new_columns <- setdiff(colnames(value), colnames(metadata)) |
||
| 1520 | |||
| 1521 | # current metadata shouldnt have columns that value doesnt have |
||
| 1522 | if(length(setdiff(colnames(metadata), colnames(value))) > 0) |
||
| 1523 | stop("Some columns of new data frame are not available in the metadata") |
||
| 1524 | |||
| 1525 | # if new columns appear, update the column names of the metadata' |
||
| 1526 | if(length(new_columns) > 0){ |
||
| 1527 | if(inherits(metadata, "data.table")){ |
||
| 1528 | value <- value[,colnames(value)[colnames(value) %in% c(colnames(metadata), new_columns)], with = FALSE] |
||
| 1529 | } else { |
||
| 1530 | value <- value[,c(colnames(metadata), new_columns)] |
||
| 1531 | } |
||
| 1532 | for(cur_col in new_columns){ |
||
| 1533 | if(is.numeric(value[[cur_col]])){ |
||
| 1534 | metadata[[cur_col]] <- NA |
||
| 1535 | } else { |
||
| 1536 | metadata[[cur_col]] <- "" |
||
| 1537 | } |
||
| 1538 | } |
||
| 1539 | } |
||
| 1540 | |||
| 1541 | # replace data |
||
| 1542 | if(!inherits(metadata, "DataFrame")){ |
||
| 1543 | # TODO: is this replace method appropriate for all dataframe types ? |
||
| 1544 | # metadata[match(value$id, metadata$id), ] <- value |
||
| 1545 | ind <- match(value$id, metadata$id) |
||
| 1546 | for(cur_col in new_columns){ |
||
| 1547 | metadata[[cur_col]][ind] <- value[[cur_col]] |
||
| 1548 | } |
||
| 1549 | } else { |
||
| 1550 | ind <- match(as.vector(value$id), as.vector(metadata$id)) |
||
| 1551 | for(cur_col in new_columns){ |
||
| 1552 | metadata[[cur_col]][ind] <- value[[cur_col]] |
||
| 1553 | } |
||
| 1554 | } |
||
| 1555 | slot(object@metadata, name = type) <- metadata |
||
| 1556 | |||
| 1557 | } else { |
||
| 1558 | stop("Some rows of new data frame are not available in the metadata") |
||
| 1559 | } |
||
| 1560 | |||
| 1561 | } else if(!is.null(rownames(metadata))){ |
||
| 1562 | |||
| 1563 | # replace the metadata (or some part of it) with the new value |
||
| 1564 | if(length(setdiff(rownames(value), rownames(metadata))) == 0){ |
||
| 1565 | |||
| 1566 | # check columns of the new table |
||
| 1567 | new_columns <- setdiff(colnames(value), colnames(metadata)) |
||
| 1568 | |||
| 1569 | # current metadata shouldn't have columns that value doesnt have |
||
| 1570 | if(length(setdiff(colnames(metadata), colnames(value))) > 0) |
||
| 1571 | stop("Some columns of new data frame are not available in the metadata") |
||
| 1572 | |||
| 1573 | # if new columns appear, update the column names of the metadata' |
||
| 1574 | if(length(new_columns) > 0){ |
||
| 1575 | value <- value[,c(colnames(metadata), new_columns)] |
||
| 1576 | for(cur_col in new_columns){ |
||
| 1577 | if(is.numeric(value[[cur_col]])){ |
||
| 1578 | metadata[[cur_col]] <- NA |
||
| 1579 | } else { |
||
| 1580 | metadata[[cur_col]] <- "" |
||
| 1581 | } |
||
| 1582 | } |
||
| 1583 | } |
||
| 1584 | |||
| 1585 | # replace data |
||
| 1586 | metadata[rownames(value), ] <- value |
||
| 1587 | slot(object@metadata, name = type) <- metadata |
||
| 1588 | } else { |
||
| 1589 | stop("Some rows of new data frame are not available in the metadata") |
||
| 1590 | } |
||
| 1591 | |||
| 1592 | } else { |
||
| 1593 | stop("The metadata should either have rownames or a column called 'id'!") |
||
| 1594 | } |
||
| 1595 | |||
| 1596 | return(object) |
||
| 1597 | } |
||
| 1598 | |||
| 1599 | #' @param value new metadata |
||
| 1600 | #' |
||
| 1601 | #' @rdname Metadata |
||
| 1602 | #' @method Metadata<- VoltRon |
||
| 1603 | #' |
||
| 1604 | #' @export |
||
| 1605 | setMethod("Metadata<-", "VoltRon", MetadataReplaceVoltRon) |
||
| 1606 | |||
| 1607 | #' addMetadata |
||
| 1608 | #' |
||
| 1609 | #' adding new columns or updating the values of the existing columns |
||
| 1610 | #' |
||
| 1611 | #' @param object a VoltRon object |
||
| 1612 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1613 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1614 | #' @param type the assay type: ROI, spot or cell, or all for the entire metadata object |
||
| 1615 | #' @param value the new values of the metadata column |
||
| 1616 | #' @param label the label of the new column, either a new column or an existing one |
||
| 1617 | #' |
||
| 1618 | #' @export |
||
| 1619 | addMetadata <- function(object, assay = NULL, type = NULL, value, label) { |
||
| 1620 | |||
| 1621 | if(!inherits(object, "VoltRon")) |
||
| 1622 | stop("Object must be of VoltRon class!") |
||
| 1623 | |||
| 1624 | # auxiliary |
||
| 1625 | `%notin%` <- Negate(`%in%`) |
||
| 1626 | |||
| 1627 | # check type |
||
| 1628 | if(is.null(type)){ |
||
| 1629 | type <- unique(vrAssayTypes(object, assay = assay)) |
||
| 1630 | if(length(type) > 1){ |
||
| 1631 | stop("You cannot update the metadata of multiple spatial entity types in the same time! See SampleMetadata()") |
||
| 1632 | } |
||
| 1633 | } |
||
| 1634 | |||
| 1635 | # sample metadata |
||
| 1636 | sample.metadata <- SampleMetadata(object) |
||
| 1637 | |||
| 1638 | # get assay names |
||
| 1639 | entities <- vrSpatialPoints(object, assay = assay) |
||
| 1640 | |||
| 1641 | # get metadata |
||
| 1642 | metadata <- slot(object@metadata, name = type) |
||
| 1643 | |||
| 1644 | # add or replace the new column |
||
| 1645 | if(label %notin% colnames(metadata)){ |
||
| 1646 | |||
| 1647 | # add empty values if the column is new |
||
| 1648 | if(is.numeric(value)){ |
||
| 1649 | metadata[[label]] <- NA |
||
| 1650 | } else { |
||
| 1651 | metadata[[label]] <- "" |
||
| 1652 | } |
||
| 1653 | } |
||
| 1654 | |||
| 1655 | # replace data |
||
| 1656 | if(length(value) == length(entities) || length(value) == 1){ |
||
| 1657 | if(is.null(rownames(metadata)) || inherits(metadata, "data.table")){ |
||
| 1658 | metadata[[label]][match(entities, as.vector(metadata$id))] <- value |
||
| 1659 | } else { |
||
| 1660 | metadata[entities,][[label]] <- value |
||
| 1661 | } |
||
| 1662 | } else { |
||
| 1663 | stop("value should be of the same length as the rows of metadata or 1!") |
||
| 1664 | } |
||
| 1665 | |||
| 1666 | # replace metadata |
||
| 1667 | slot(object@metadata, name = type) <- metadata |
||
| 1668 | |||
| 1669 | # return |
||
| 1670 | return(object) |
||
| 1671 | } |
||
| 1672 | |||
| 1673 | |||
| 1674 | #' SampleMetadata |
||
| 1675 | #' |
||
| 1676 | #' Get the sample metadata of a VoltRon object |
||
| 1677 | #' |
||
| 1678 | #' @param object a VoltRon object |
||
| 1679 | #' |
||
| 1680 | #' @export |
||
| 1681 | SampleMetadata <- function(object) { |
||
| 1682 | object@sample.metadata |
||
| 1683 | } |
||
| 1684 | |||
| 1685 | #### Spatial #### |
||
| 1686 | |||
| 1687 | vrCoordinatesVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, reg = FALSE) { |
||
| 1688 | |||
| 1689 | # get assay names |
||
| 1690 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1691 | |||
| 1692 | # get sample metadata |
||
| 1693 | sample_metadata <- SampleMetadata(object) |
||
| 1694 | |||
| 1695 | # get spatial name |
||
| 1696 | if(!is.null(spatial_name)) |
||
| 1697 | image_name <- spatial_name |
||
| 1698 | |||
| 1699 | # get all coordinates |
||
| 1700 | coords <- NULL |
||
| 1701 | for(assy in assay_names){ |
||
| 1702 | |||
| 1703 | # get coordinates |
||
| 1704 | cur_coords <- vrCoordinates(object[[assy]], image_name = image_name, reg = reg) |
||
| 1705 | if(inherits(cur_coords, "IterableMatrix")) |
||
| 1706 | cur_coords <- as.matrix(as(cur_coords, "dgCMatrix")) |
||
| 1707 | |||
| 1708 | # update zlocation |
||
| 1709 | sample_name <- sample_metadata[assy, "Sample"] |
||
| 1710 | |||
| 1711 | catch_connect <- try(slot(object[[sample_name]], name = "zlocation"), silent = TRUE) |
||
| 1712 | if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){ |
||
| 1713 | zlocation <- object[[sample_name]]@zlocation |
||
| 1714 | cur_coords[,"z"] <- rep(zlocation[sample_metadata[assy, "Layer"]], nrow(cur_coords)) |
||
| 1715 | } |
||
| 1716 | |||
| 1717 | # merge coordinates |
||
| 1718 | if(!is.null(coords)){ |
||
| 1719 | coords <- rbind(coords, cur_coords) |
||
| 1720 | } else { |
||
| 1721 | coords <- cur_coords |
||
| 1722 | } |
||
| 1723 | } |
||
| 1724 | |||
| 1725 | # return image |
||
| 1726 | return(coords) |
||
| 1727 | } |
||
| 1728 | |||
| 1729 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1730 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1731 | #' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image associated with the coordinates |
||
| 1732 | #' @param spatial_name the name/key of the spatial system associated with the coordinates |
||
| 1733 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainImage}) is requested |
||
| 1734 | #' |
||
| 1735 | #' @rdname vrCoordinates |
||
| 1736 | #' @order 2 |
||
| 1737 | #' @export |
||
| 1738 | setMethod("vrCoordinates", "VoltRon", vrCoordinatesVoltRon) |
||
| 1739 | |||
| 1740 | vrCoordinatesReplaceVoltRon <- function(object, image_name = NULL, spatial_name = NULL, reg = FALSE, value) { |
||
| 1741 | |||
| 1742 | # sample metadata |
||
| 1743 | sample.metadata <- SampleMetadata(object) |
||
| 1744 | |||
| 1745 | # check the number of assays in the object |
||
| 1746 | if(nrow(sample.metadata) > 1) |
||
| 1747 | stop("Changing the coordinates of multiple assays in the same time are not permitted!") |
||
| 1748 | |||
| 1749 | # get assay |
||
| 1750 | cur_assay <- sample.metadata[1,] |
||
| 1751 | vrlayer <- object[[cur_assay$Sample, cur_assay$Layer]] |
||
| 1752 | vrassay <- vrlayer[[cur_assay$Assay]] |
||
| 1753 | |||
| 1754 | # get spatial name |
||
| 1755 | if(!is.null(spatial_name)) |
||
| 1756 | image_name <- spatial_name |
||
| 1757 | |||
| 1758 | # change coordinates |
||
| 1759 | vrCoordinates(vrassay, spatial_name = image_name, reg = reg) <- value |
||
| 1760 | vrlayer[[cur_assay$Assay]] <- vrassay |
||
| 1761 | object[[cur_assay$Sample, cur_assay$Layer]] <- vrlayer |
||
| 1762 | |||
| 1763 | return(object) |
||
| 1764 | } |
||
| 1765 | |||
| 1766 | #' @param value new coordinates of spatial points |
||
| 1767 | #' |
||
| 1768 | #' @rdname vrCoordinates |
||
| 1769 | #' @order 4 |
||
| 1770 | #' @export |
||
| 1771 | setMethod("vrCoordinates<-", "VoltRon", vrCoordinatesReplaceVoltRon) |
||
| 1772 | |||
| 1773 | vrSegmentsVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, reg = FALSE, as.data.frame = FALSE) { |
||
| 1774 | |||
| 1775 | # get assay names |
||
| 1776 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1777 | |||
| 1778 | # get spatial name |
||
| 1779 | if(!is.null(spatial_name)) |
||
| 1780 | image_name <- spatial_name |
||
| 1781 | |||
| 1782 | # get all coordinates |
||
| 1783 | segts <- NULL |
||
| 1784 | for(assy in assay_names) |
||
| 1785 | segts <- c(segts, vrSegments(object[[assy]], spatial_name = image_name, reg = reg)) |
||
| 1786 | |||
| 1787 | if(as.data.frame) |
||
| 1788 | segts <- do.call(rbind, segts) |
||
| 1789 | |||
| 1790 | # return image |
||
| 1791 | return(segts) |
||
| 1792 | } |
||
| 1793 | |||
| 1794 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1795 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1796 | #' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image associated with the coordinates |
||
| 1797 | #' @param spatial_name the name/key of the spatial system associated with the coordinates |
||
| 1798 | #' @param reg TRUE if registered coordinates of the main image (\link{vrMainImage}) is requested |
||
| 1799 | #' @param as.data.frame if TRUE, the coordinates of segment nodes will be returned as a data frame |
||
| 1800 | #' |
||
| 1801 | #' @rdname vrSegments |
||
| 1802 | #' @order 2 |
||
| 1803 | #' @export |
||
| 1804 | setMethod("vrSegments", "VoltRon", vrSegmentsVoltRon) |
||
| 1805 | |||
| 1806 | vrSegmentsReplaceVoltRon <- function(object, image_name = NULL, spatial_name = NULL, reg = FALSE, value) { |
||
| 1807 | |||
| 1808 | # sample metadata |
||
| 1809 | sample.metadata <- SampleMetadata(object) |
||
| 1810 | |||
| 1811 | # check the number of assays in the object |
||
| 1812 | if(nrow(sample.metadata) > 1) |
||
| 1813 | stop("Changing the coordinates of multiple assays are not permitted!") |
||
| 1814 | |||
| 1815 | # get assay |
||
| 1816 | cur_assay <- sample.metadata[1,] |
||
| 1817 | vrlayer <- object[[cur_assay$Sample, cur_assay$Layer]] |
||
| 1818 | vrassay <- vrlayer[[cur_assay$Assay]] |
||
| 1819 | |||
| 1820 | # get spatial name |
||
| 1821 | if(!is.null(spatial_name)) |
||
| 1822 | image_name <- spatial_name |
||
| 1823 | |||
| 1824 | # change coordinates |
||
| 1825 | vrSegments(vrassay, spatial_name = image_name, reg = reg) <- value |
||
| 1826 | vrlayer[[cur_assay$Assay]] <- vrassay |
||
| 1827 | object[[cur_assay$Sample, cur_assay$Layer]] <- vrlayer |
||
| 1828 | |||
| 1829 | return(object) |
||
| 1830 | } |
||
| 1831 | |||
| 1832 | #' @param value new segment coordinates of spatial points |
||
| 1833 | #' |
||
| 1834 | #' @rdname vrSegments |
||
| 1835 | #' @order 5 |
||
| 1836 | #' @export |
||
| 1837 | setMethod("vrSegments<-", "VoltRon", vrSegmentsReplaceVoltRon) |
||
| 1838 | |||
| 1839 | flipCoordinatesVoltRon <- function(object, assay = NULL, image_name = NULL, spatial_name = NULL, ...){ |
||
| 1840 | |||
| 1841 | # get assay names |
||
| 1842 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1843 | |||
| 1844 | # get spatial name |
||
| 1845 | if(!is.null(spatial_name)) |
||
| 1846 | image_name <- spatial_name |
||
| 1847 | |||
| 1848 | # flip coordinates |
||
| 1849 | for(assy in assay_names){ |
||
| 1850 | object[[assy]] <- flipCoordinates(object[[assy]], spatial_name = image_name, ...) |
||
| 1851 | } |
||
| 1852 | return(object) |
||
| 1853 | } |
||
| 1854 | |||
| 1855 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1856 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1857 | #' @param image_name (deprecated, use \code{spatial_name}) the name/key of the image |
||
| 1858 | #' @param spatial_name the name/key of the spatial system associated with the coordinates |
||
| 1859 | #' @param ... additional parameters passed to \link{vrCoordinates} and \link{vrSegments} |
||
| 1860 | #' |
||
| 1861 | #' @rdname flipCoordinates |
||
| 1862 | #' @order 2 |
||
| 1863 | #' |
||
| 1864 | #' @export |
||
| 1865 | setMethod("flipCoordinates", "VoltRon", flipCoordinatesVoltRon) |
||
| 1866 | |||
| 1867 | #### Graphs #### |
||
| 1868 | |||
| 1869 | #' vrGraph |
||
| 1870 | #' |
||
| 1871 | #' Get graph of a VoltRon object |
||
| 1872 | #' |
||
| 1873 | #' @param object a VoltRon object |
||
| 1874 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1875 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1876 | #' @param graph.type the type of the graph, either custom or given by \link{getProfileNeighbors} or \link{getSpatialNeighbors} functions |
||
| 1877 | #' |
||
| 1878 | #' @rdname vrGraph |
||
| 1879 | #' |
||
| 1880 | #' @importFrom igraph induced_subgraph V |
||
| 1881 | #' |
||
| 1882 | #' @export |
||
| 1883 | vrGraph <- function(object, assay = NULL, graph.type = NULL) { |
||
| 1884 | |||
| 1885 | # get assay names |
||
| 1886 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1887 | node_names <- vrSpatialPoints(object, assay = assay_names) |
||
| 1888 | |||
| 1889 | # check if there exists graphs |
||
| 1890 | if(length(names(object@graph)) == 0) |
||
| 1891 | stop("There are no graphs in this VoltRon object!") |
||
| 1892 | |||
| 1893 | # check graph type |
||
| 1894 | if(is.null(graph.type)){ |
||
| 1895 | graph.type <- vrGraphNames(object) |
||
| 1896 | if(length(graph.type) == 0){ |
||
| 1897 | stop("There are no graphs in this VoltRon object!") |
||
| 1898 | } |
||
| 1899 | graph.type <- graph.type[1] |
||
| 1900 | } else { |
||
| 1901 | if(!graph.type %in% vrGraphNames(object)) |
||
| 1902 | stop("The graph name '", graph.type, "' can't be found in this VoltRon object!") |
||
| 1903 | } |
||
| 1904 | |||
| 1905 | # return graph |
||
| 1906 | if(length(vrGraphNames(object)) > 0){ |
||
| 1907 | node_names <- intersect(igraph::V(object@graph[[graph.type]])$name, node_names) |
||
| 1908 | returngraph <- igraph::induced_subgraph(object@graph[[graph.type]], node_names) |
||
| 1909 | return(returngraph) |
||
| 1910 | } else { |
||
| 1911 | warning("This VoltRon object does not have any graphs yet!") |
||
| 1912 | return(NULL) |
||
| 1913 | } |
||
| 1914 | } |
||
| 1915 | |||
| 1916 | #' @param value new graph |
||
| 1917 | #' |
||
| 1918 | #' @rdname vrGraph |
||
| 1919 | #' |
||
| 1920 | #' @importFrom igraph disjoint_union induced_subgraph V |
||
| 1921 | #' @export |
||
| 1922 | "vrGraph<-" <- function(object, assay = NULL, graph.type = "kNN", value) { |
||
| 1923 | |||
| 1924 | # check value |
||
| 1925 | if(!inherits(value, "igraph")) |
||
| 1926 | stop("The 'value' should be of an igraph class!") |
||
| 1927 | |||
| 1928 | # get assay names |
||
| 1929 | assay_names <- vrAssayNames(object, assay = assay) |
||
| 1930 | spobject <- vrSpatialPoints(object, assay = assay_names) |
||
| 1931 | |||
| 1932 | # check if there exists graphs |
||
| 1933 | graph <- object@graph |
||
| 1934 | if(length(names(object@graph)) == 0 || !graph.type %in% names(object@graph)){ |
||
| 1935 | |||
| 1936 | # graph[[graph.type]] <- make_empty_graph(directed = FALSE) + vertices(spobject) |
||
| 1937 | graph[[graph.type]] <- value |
||
| 1938 | |||
| 1939 | } else { |
||
| 1940 | |||
| 1941 | # vertices |
||
| 1942 | new_vert <- igraph::V(value)$name |
||
| 1943 | |||
| 1944 | # edges |
||
| 1945 | subg_inv <- igraph::induced_subgraph(graph[[graph.type]], spobject[!spobject%in%new_vert]) |
||
| 1946 | graph[[graph.type]] <- igraph::disjoint_union(value, subg_inv) |
||
| 1947 | } |
||
| 1948 | |||
| 1949 | # update object |
||
| 1950 | object@graph <- graph |
||
| 1951 | |||
| 1952 | # return |
||
| 1953 | return(object) |
||
| 1954 | } |
||
| 1955 | |||
| 1956 | #' vrGraphNames |
||
| 1957 | #' |
||
| 1958 | #' Get names of all graphs |
||
| 1959 | #' |
||
| 1960 | #' @param object a VoltRon object |
||
| 1961 | #' @param assay assay name (exp: Assay1) or assay class (exp: Visium, Xenium), see \link{SampleMetadata}. |
||
| 1962 | #' if NULL, the default assay will be used, see \link{vrMainAssay}. |
||
| 1963 | #' |
||
| 1964 | #' @rdname vrGraphNames |
||
| 1965 | #' |
||
| 1966 | #' @export |
||
| 1967 | vrGraphNames <- function(object, assay = NULL){ |
||
| 1968 | return(names(object@graph)) |
||
| 1969 | } |
||
| 1970 | |||
| 1971 | #' subset_graphs |
||
| 1972 | #' |
||
| 1973 | #' Given a VoltRon object and a vrMetadata, subset the graph |
||
| 1974 | #' |
||
| 1975 | #' @param object a VoltRon Object |
||
| 1976 | #' @param spatialpoints a set of spatial points |
||
| 1977 | #' |
||
| 1978 | #' @importFrom igraph subgraph V |
||
| 1979 | #' |
||
| 1980 | #' @noRd |
||
| 1981 | subset_graphs <- function(object, spatialpoints){ |
||
| 1982 | |||
| 1983 | # graph names |
||
| 1984 | graphnames <- vrGraphNames(object) |
||
| 1985 | |||
| 1986 | # for all graphs |
||
| 1987 | if(!is.null(graphnames)){ |
||
| 1988 | graph_list <- object@graph |
||
| 1989 | for(g in vrGraphNames(object)){ |
||
| 1990 | cur_graph <- graph_list[[g]] |
||
| 1991 | cur_graph<- igraph::subgraph(cur_graph, igraph::V(cur_graph)[names(igraph::V(cur_graph)) %in% spatialpoints]) |
||
| 1992 | graph_list[[g]] <- cur_graph |
||
| 1993 | } |
||
| 1994 | } else { |
||
| 1995 | graph_list <- list() |
||
| 1996 | } |
||
| 1997 | |||
| 1998 | return(graph_list) |
||
| 1999 | } |
||
| 2000 | |||
| 2001 | #' merge_graphs |
||
| 2002 | #' |
||
| 2003 | #' Given a VoltRon object, and a list of VoltRon objects, merge their graphs. |
||
| 2004 | #' |
||
| 2005 | #' @param object a VoltRon Object |
||
| 2006 | #' @param object_list a list of VoltRon objects |
||
| 2007 | #' |
||
| 2008 | #' @importFrom igraph disjoint_union |
||
| 2009 | #' |
||
| 2010 | #' @noRd |
||
| 2011 | merge_graphs <- function(object, object_list){ |
||
| 2012 | |||
| 2013 | # combine all elements |
||
| 2014 | if(!is.list(object_list)) |
||
| 2015 | object_list <- list(object_list) |
||
| 2016 | if(inherits(object, "VoltRon")){ |
||
| 2017 | object_list <- c(object, object_list) |
||
| 2018 | } else { |
||
| 2019 | object_list <- c(list(object), object_list) |
||
| 2020 | } |
||
| 2021 | |||
| 2022 | # choose objects |
||
| 2023 | obj1 <- object_list[[1]] |
||
| 2024 | obj2 <- object_list[[2]] |
||
| 2025 | |||
| 2026 | # initial combination |
||
| 2027 | if(length(object_list) > 2){ |
||
| 2028 | combined_graph <- merge_graphs(obj1, obj2) |
||
| 2029 | for(i in 3:(length(object_list))){ |
||
| 2030 | combined_graph <- merge_graphs(combined_graph, object_list[[i]]) |
||
| 2031 | } |
||
| 2032 | } else { |
||
| 2033 | updateobjects <- updateGraphAssay(obj1, obj2) |
||
| 2034 | obj1 <- updateobjects$object1 |
||
| 2035 | obj2 <- updateobjects$object2 |
||
| 2036 | combined_graph <- igraph::disjoint_union(obj1, obj2) |
||
| 2037 | } |
||
| 2038 | |||
| 2039 | return(combined_graph) |
||
| 2040 | } |
||
| 2041 | |||
| 2042 | #' updateGraphAssay |
||
| 2043 | #' |
||
| 2044 | #' @param object1 VoltRon object |
||
| 2045 | #' @param object2 VoltRon object |
||
| 2046 | #' |
||
| 2047 | #' @importFrom igraph V |
||
| 2048 | #' @importFrom stringr str_extract |
||
| 2049 | #' |
||
| 2050 | #' @noRd |
||
| 2051 | updateGraphAssay <- function(object1, object2){ |
||
| 2052 | |||
| 2053 | if(inherits(object1, "VoltRon")) |
||
| 2054 | object1 <- vrGraph(object1, assay = "all") |
||
| 2055 | if(inherits(object2, "VoltRon")) |
||
| 2056 | object2 <- vrGraph(object2, assay = "all") |
||
| 2057 | |||
| 2058 | # get assay types |
||
| 2059 | assaytype <- unique(stringr::str_extract(igraph::V(object1)$name, "Assay[0-9]+$")) |
||
| 2060 | assaytype <- assaytype[order(nchar(assaytype), assaytype)] |
||
| 2061 | |||
| 2062 | # replace assay names |
||
| 2063 | replacement <- paste0("Assay", seq_len(length(assaytype))) |
||
| 2064 | vertex_names <- igraph::V(object1)$name |
||
| 2065 | temp <- vertex_names |
||
| 2066 | for(i in seq_len(length(assaytype))) |
||
| 2067 | temp[grepl(paste0(assaytype[i],"$"), vertex_names)] <- gsub(paste0(assaytype[i],"$"), replacement[i], |
||
| 2068 | vertex_names[grepl(paste0(assaytype[i],"$"), vertex_names)]) |
||
| 2069 | igraph::V(object1)$name <- temp |
||
| 2070 | |||
| 2071 | # get assay types |
||
| 2072 | assaytype <- unique(stringr::str_extract(igraph::V(object2)$name, "Assay[0-9]+$")) |
||
| 2073 | assaytype <- assaytype[order(nchar(assaytype), assaytype)] |
||
| 2074 | |||
| 2075 | # replace assay names |
||
| 2076 | replacement <- paste0("Assay", (length(replacement)+1):(length(replacement) + length(assaytype))) |
||
| 2077 | vertex_names <- igraph::V(object2)$name |
||
| 2078 | temp <- vertex_names |
||
| 2079 | for(i in seq_len(length(assaytype))) |
||
| 2080 | temp[grepl(paste0(assaytype[i],"$"), vertex_names)] <- gsub(paste0(assaytype[i],"$"), replacement[i], |
||
| 2081 | vertex_names[grepl(paste0(assaytype[i],"$"), vertex_names)]) |
||
| 2082 | igraph::V(object2)$name <- temp |
||
| 2083 | |||
| 2084 | # return |
||
| 2085 | return(list(object1 = object1, object2 = object2)) |
||
| 2086 | } |
||
| 2087 | |||
| 2088 | #' combineGraphs |
||
| 2089 | #' |
||
| 2090 | #' Combining the edges of multiple graphs |
||
| 2091 | #' |
||
| 2092 | #' @param object a VoltRon Object |
||
| 2093 | #' @param graph.names a vector of graph names |
||
| 2094 | #' @param graph.weights the weights for edges of each graph. |
||
| 2095 | #' @param graph.key the name of the combined graph |
||
| 2096 | #' |
||
| 2097 | #' @importFrom igraph union edge_attr_names as_adjacency_matrix graph_from_adjacency_matrix |
||
| 2098 | #' |
||
| 2099 | #' @export |
||
| 2100 | combineGraphs <- function(object, graph.names = NULL, graph.weights = NULL, graph.key = "combined"){ |
||
| 2101 | |||
| 2102 | if(!inherits(object, "VoltRon")) |
||
| 2103 | stop("Object must be of VoltRon class!") |
||
| 2104 | |||
| 2105 | if(length(graph.names) == 0) |
||
| 2106 | stop("Please provide graph names") |
||
| 2107 | |||
| 2108 | if(any(!graph.names %in% vrGraphNames(object))){ |
||
| 2109 | graph.names <- setdiff(graph.names, vrGraphNames(object)) |
||
| 2110 | stop("The following graphs are not included in the VoltRon object: ", |
||
| 2111 | paste(graph.names, sep = ",", collapse = TRUE)) |
||
| 2112 | } |
||
| 2113 | |||
| 2114 | # check weights |
||
| 2115 | if(is.null(graph.weights)){ |
||
| 2116 | graph.weights <- rep(0.5, length(graph.names)) |
||
| 2117 | } |
||
| 2118 | if(length(graph.weights) != length(graph.names)){ |
||
| 2119 | stop("The weights should be of the length of graph names") |
||
| 2120 | } |
||
| 2121 | if(any(!is.numeric(graph.weights))){ |
||
| 2122 | stop("Weights should be numeric") |
||
| 2123 | } |
||
| 2124 | if(sum(graph.weights) != 1){ |
||
| 2125 | stop("Weights should sum up to 1!") |
||
| 2126 | } |
||
| 2127 | names(graph.weights) <- graph.names |
||
| 2128 | |||
| 2129 | # collect graphs |
||
| 2130 | allmat <- NULL |
||
| 2131 | for(gr in graph.names){ |
||
| 2132 | cur_graph <- vrGraph(object, graph.type = gr) |
||
| 2133 | if("weight" %in% igraph::edge_attr_names(cur_graph)){ |
||
| 2134 | adjmat <- igraph::as_adjacency_matrix(cur_graph, attr = "weight") |
||
| 2135 | } else { |
||
| 2136 | adjmat <- igraph::as_adjacency_matrix(cur_graph) |
||
| 2137 | } |
||
| 2138 | adjmat <- adjmat*graph.weights[gr] |
||
| 2139 | if(is.null(allmat)){ |
||
| 2140 | allmat <- adjmat |
||
| 2141 | } else { |
||
| 2142 | allmat <- allmat + adjmat |
||
| 2143 | } |
||
| 2144 | } |
||
| 2145 | |||
| 2146 | # union of graphs |
||
| 2147 | vrGraph(object, graph.type = graph.key) <- igraph::graph_from_adjacency_matrix(allmat, mode = "undirected", weighted = TRUE, diag = FALSE) |
||
| 2148 | |||
| 2149 | # return |
||
| 2150 | return(object) |
||
| 2151 | } |
||
| 2152 |