## vrSample ####
### subset ####
#' Methods for vrSample objects
#'
#' Methods for \code{\link{vrSample}} objects for generics defined in other
#' packages
#'
#' @param x A vrSample object
#' @param i the name of layer associated with the sample, see \link{SampleMetadata}
#' @param value a vrLayer object, see \link{vrLayer}
#'
#' @name vrSample-methods
#' @rdname vrSample-methods
#'
#' @concept vrsample
#'
NULL
#' @describeIn vrSample-methods Accessing vrLayer objects from \code{vrSample} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[',
signature = c('vrSample', "character"),
definition = function(x, i){
# sample names
layer_names <- names(methods::slot(x, "layer"))
# check query sample name
if(!i %in% layer_names){
stop("There are no layers named ", i, " in this sample")
}
# return samples
return(x@layer[[i]])
}
)
#' @describeIn vrSample-methods Accessing vrLayer objects from \code{vrSample} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[<-',
signature = c('vrSample', "character"),
definition = function(x, i, value){
# check if value if vrLayer
if(!inherits(value, "vrLayer")){
stop("The provided object is not of class vrLayer")
}
# sample names
layer_names <- names(methods::slot(x, "layer"))
# check query sample name
if(!i %in% layer_names){
stop("There are no layers named ", i, " in this sample")
}
# change layer
x@layer[[i]] <- value
# return
return(x)
}
)
## vrBlock ####
### subset ####
#' @describeIn vrSample-methods (deprecated) Accessing vrLayer objects from \code{vrBlock} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[',
signature = c('vrBlock', "character"),
definition = function(x, i){
# sample names
layer_names <- names(methods::slot(x, "layer"))
# check query sample name
if(!i %in% layer_names){
stop("There are no layers named ", i, " in this sample")
}
# return samples
return(x@layer[[i]])
}
)
#' @describeIn vrSample-methods (deprecated) Overwriting vrLayer objects from \code{vrBlock} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[<-',
signature = c('vrBlock', "character"),
definition = function(x, i, value){
# check if value if vrLayer
if(!inherits(value, "vrLayer")){
stop("The provided object is not of class vrLayer")
}
# sample names
layer_names <- names(methods::slot(x, "layer"))
# check query sample name
if(!i %in% layer_names){
stop("There are no layers named ", i, " in this sample")
}
# change layer
x@layer[[i]] <- value
# return
return(x)
}
)
## vrLayer ####
### subset ####
#' Methods for vrLayer objects
#'
#' Methods for \code{\link{vrLayer}} objects for generics defined in other
#' packages
#'
#' @param x A vrLayer object
#' @param i the name of assay associated with the layer, see \link{SampleMetadata}
#' @param value a vrAssayV2 object, see \link{vrAssayV2}
#'
#' @name vrLayer-methods
#' @rdname vrLayer-methods
#'
#' @concept vrlayer
#'
NULL
#' @describeIn vrLayer-methods Accessing vrAssay objects from \code{vrLayer} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[',
signature = c('vrLayer', "character"),
definition = function(x, i){
# if no assay were found, check sample names
assay_names <- names(methods::slot(x, "assay"))
# check query sample name
if(!i %in% assay_names){
stop("There are no assays named ", i, " in this object")
} else {
return(x@assay[[i]])
}
}
)
#' @describeIn vrLayer-methods Overwriting vrAssay objects from \code{vrLayer} objects
#'
#' @importFrom methods slot
setMethod(
f = '[[<-',
signature = c('vrLayer', "character"),
definition = function(x, i, value){
# if no assay were found, check sample names
assay_names <- names(methods::slot(x, "assay"))
# check query sample name
if(!i %in% assay_names){
stop("There are no assays named ", i, " in this object")
}
x@assay[[i]] <- value
return(x)
}
)
####
# Methods ####
####
### vrSample Methods ####
mergevrSample <- function(x, y, samples = NULL){
# 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)
names(object_list) <- samples
# set VoltRon class
return(object_list)
}
#' Merging vrSample objects
#'
#' Given a vrSample object, and a list of vrSample objects, merge all.
#'
#' @param x a vrSample object
#' @param y a list of vrSample objects
#' @param samples the sample names
#'
#' @method merge vrSample
setMethod("merge", "vrSample", mergevrSample)
#' Merging vrBlock objects
#'
#' Given a vrBlock object, and a list of vrSample objects, merge all.
#'
#' @param x a vrSample object
#' @param y a list of vrSample objects
#' @param samples the sample names
#'
#' @method merge vrBlock
setMethod("merge", "vrBlock", mergevrSample)
# merge.vrBlock <- function(object, object_list, samples = NULL){
# merge.vrSample(object, object_list = object_list, samples = samples)
# }
subsetvrSample <- function(x, subset, assays = NULL, spatialpoints = NULL, image = NULL) {
# start
object <- x
if (!missing(x = subset)) {
subset <- enquo(arg = subset)
}
# subseting on samples, layers and assays
layers <- object@layer
if(!is.null(assays)){
object@layer <- sapply(layers, function(lay) {
subsetvrLayer(lay, assays = assays)
}, USE.NAMES = TRUE, simplify = TRUE)
} else if(!is.null(spatialpoints)){
object@layer <- sapply(layers, function(lay) {
subsetvrLayer(lay, spatialpoints = spatialpoints)
}, USE.NAMES = TRUE, simplify = TRUE)
} else if(!is.null(image)){
object@layer <- sapply(layers, function(lay) {
subsetvrLayer(lay, image = image)
}, USE.NAMES = TRUE, simplify = TRUE)
}
# remove NULL assays
ind <- which(vapply(object@layer, function(x) !is.null(x), logical(1)))
object@layer <- object@layer[ind]
# check if there are layers
if(length(object@layer) > 0){
# get updated adjaceny and distance
catch_connect <- try(slot(object, name = "zlocation"), silent = TRUE)
if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){
object@zlocation <- object@zlocation[ind]
object@adjacency <- object@adjacency[ind, ind, drop = FALSE]
}
# return object
return(object)
} else {
return(NULL)
}
}
#' Subsetting vrSample objects
#'
#' Given a vrSample object, subset the object given one of the attributes
#'
#' @param x a vrSample object
#' @param subset the subset statement
#' @param assays the set of assays to subset the object
#' @param spatialpoints the set of spatial points to subset the object
#' @param image the subseting string passed to \link{image_crop}
#'
#' @method subset vrSample
#' @order 6
#'
#' @importFrom rlang enquo
setMethod("subset", "vrSample", subsetvrSample)
#' Subsetting vrBlock objects
#'
#' Given a vrBlock object, subset the object given one of the attributes
#'
#' @param x a vrSample object
#' @param subset the subset statement
#' @param assays the set of assays to subset the object
#' @param spatialpoints the set of spatial points to subset the object
#' @param image the subseting string passed to \link{image_crop}
#'
#' @method subset vrBlock
#' @order 6
setMethod("subset", "vrBlock", subsetvrSample)
# subset.vrBlock <- function(object, subset, assays = NULL, spatialpoints = NULL, image = NULL){
# subset.vrSample(object, subset = subset, assays = assays, spatialpoints = spatialpoints, image = image)
# }
#' @rdname vrSpatialPoints
#' @order 5
#' @export
setMethod("vrSpatialPoints", "vrSample", function(object) {
do.call("c", lapply(object@layer, function(lay) {
vrSpatialPoints(lay)
}))
})
#' @rdname vrSpatialPoints
#' @order 5
#' @export
setMethod("vrSpatialPoints", "vrBlock", function(object) {
do.call("c", lapply(object@layer, function(lay) {
vrSpatialPoints(lay)
}))
})
changeAssayNamesvrSample <- function(object, sample.metadata = NULL){
if(is.null(sample.metadata))
stop("Please provide a sample.metadata")
if(!"NewAssayNames" %in% colnames(sample.metadata))
stop("Please provide a sample.metadata with NewAssayNames column which includes the new assay names")
# change the assay names of the layers
layer_names <- names(object@layer)
for(lyr in layer_names)
object[[lyr]] <- changeAssayNames(object[[lyr]], sample.metadata = sample.metadata[sample.metadata$Layer == lyr,])
# return
return(object)
}
#' changeAssayNames.vrSample
#'
#' Change the assay names of assays within a vrSample object
#'
#' @param sample.metadata the sample metadata with NewAssayNames column which includes the new assay names
#'
#' @rdname changeAssayNames
#'
#' @noRd
setMethod("changeAssayNames", "vrSample", changeAssayNamesvrSample)
changeAssayNamesvrBlock <- function(object, sample.metadata = NULL) {
object <- changeAssayNamesvrSample(object, sample.metadata = sample.metadata)
return(object)
}
#' changeAssayNames.vrBlock
#'
#' Change the assay names of assays within a vrBlock object
#'
#' @param sample.metadata the sample metadata with NewAssayNames column which includes the new assay names
#'
#' @rdname changeAssayNames
#'
#' @noRd
setMethod("changeAssayNames", "vrBlock", changeAssayNamesvrBlock)
### vrLayer Methods ####
subsetvrLayer <- function(x, subset, assays = NULL, spatialpoints = NULL, image = NULL) {
# start
object <- x
if (!missing(x = subset)) {
subset <- enquo(arg = subset)
}
# subseting on samples, layers and assays
if(!is.null(assays)){
# get assay names of all assays
assay_names <- vapply(object@assay, vrAssayNames, character(1))
if(any(assays %in% assay_names)) {
assays <- intersect(assays, assay_names)
object@assay <- object@assay[which(assay_names %in% assays)]
} else if(any(assays %in% names(object@assay))) {
object@assay <- object@assay[names(object@assay) %in% assays]
} else {
return(NULL)
}
} else if(!is.null(spatialpoints)){
# get points connected to queried spatialpoints
catch_connect <- try(slot(object, name = "connectivity"), silent = TRUE)
if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){
if(igraph::vcount(object@connectivity) > 0){
spatialpoints <- getConnectedSpatialPoints(object, spatialpoints)
object@connectivity <- subset.Connectivity(object@connectivity, spatialpoints)
}
}
# subset assays
object@assay <- sapply(object@assay, function(assy) {
if(inherits(assy, "vrAssay")){
# return(subset.vrAssay(assy, spatialpoints = spatialpoints))
return(subsetvrAssay(assy, spatialpoints = spatialpoints))
} else {
# return(subset.vrAssayV2(assy, spatialpoints = spatialpoints))
return(subsetvrAssay(assy, spatialpoints = spatialpoints))
}
}, USE.NAMES = TRUE, simplify = TRUE)
} else if(!is.null(image)){
object@assay <- sapply(object@assay, function(assy) {
if(inherits(assy, "vrAssay")){
# return(subset.vrAssay(assy, image = image))
return(subsetvrAssay(assy, image = image))
} else {
return(subsetvrAssay(assy, image = image))
}
}, USE.NAMES = TRUE, simplify = TRUE)
}
# remove NULL assays
object@assay <- object@assay[which(vapply(object@assay, function(x) !is.null(x), logical(1)))]
# set VoltRon class
if(length(object@assay) > 0){
return(object)
} else {
return(NULL)
}
}
#' Subsetting vrLayer objects
#'
#' Given a vrLayer object, subset the object given one of the attributes
#'
#' @param x a vrLayer object
#' @param subset the subset statement
#' @param assays the set of assays to subset the object
#' @param spatialpoints the set of spatial points to subset the object
#' @param image the subseting string passed to \link{image_crop}
#'
#' @method subset vrLayer
#' @order 7
#'
#' @importFrom rlang enquo
#' @importFrom methods is
setMethod("subset", "vrLayer", subsetvrLayer)
#' @rdname vrSpatialPoints
#' @order 6
#' @export
setMethod("vrSpatialPoints", "vrLayer", function(object) {
do.call("c", lapply(object@assay, function(assy) {
vrSpatialPoints(assy)
}))
})
#' subset.Connectivity
#'
#' Subsetting the connectivity graph of vrLayer using spatial points
#'
#' @param object the connectivity graph of the vrLayer
#' @param spatialpoints the set of spatial points
#'
#' @importFrom igraph induced_subgraph
#'
#' @noRd
subset.Connectivity <- function(object, spatialpoints = NULL){
return(igraph::induced_subgraph(object, spatialpoints))
}
#' getConnectedSpatialPoints
#'
#' get spatial points connected to other spatial points in the connectivity graph of vrLayer
#'
#' @param object A vrLayer object
#' @param spatialpoints the set of spatial points
#'
#' @importFrom igraph neighborhood V vcount
#'
#' @noRd
getConnectedSpatialPoints <- function(object, spatialpoints = NULL){
if(igraph::vcount(object@connectivity) > 0){
spatialpoints <- intersect(spatialpoints, igraph::V(object@connectivity)$name)
return(names(unlist(igraph::neighborhood(object@connectivity, nodes = spatialpoints))))
} else {
return(spatialpoints)
}
}
changeAssayNamesvrLayer <- function(object, sample.metadata = NULL){
if(is.null(sample.metadata))
stop("Please provide a sample.metadata")
if(!"NewAssayNames" %in% colnames(sample.metadata))
stop("Please provide a sample.metadata with NewAssayNames column which includes the new assay names")
# change the assay names of the connectivity graph if exists
catch_connect <- try(slot(object, name = "connectivity"), silent = TRUE)
if(!is(catch_connect, 'try-error') && !methods::is(catch_connect,'error')){
if(igraph::vcount(object@connectivity) > 0){
spatialpoints <- igraph::V(object@connectivity)$name
old_assay_names <- vapply(object@assay, vrAssayNames, character(1))
new_assay_names <- sample.metadata$NewAssayNames
cur_spatialpoints <- spatialpoints
for(i in seq_len(length(old_assay_names))){
if(old_assay_names[i]!=new_assay_names[i]){
ind <- grepl(paste0(old_assay_names[i],"$"), spatialpoints)
cur_spatialpoints[ind] <- gsub(paste0(old_assay_names[i],"$"), new_assay_names[i], spatialpoints[ind])
}
}
igraph::V(object@connectivity)$name <- cur_spatialpoints
}
}
# change the assay names of vrAssays
assay_names <- names(object@assay)
for(assy in assay_names)
vrAssayNames(object[[assy]]) <- rownames(sample.metadata[sample.metadata$Assay == assy,])
# return
return(object)
}
#' changeAssayNamesvrLayer
#'
#' Change the assay names of assays within a vrSample object
#'
#' @rdname changeAssayNames
#'
#' @importFrom igraph V V<- vcount
#' @importFrom methods is
#'
#' @noRd
setMethod("changeAssayNames", "vrLayer", changeAssayNamesvrLayer)
Datasets
Models
