Nothing
#' @include zzz.R
#' @include generics.R
#' @importFrom methods as callNextMethod
#' @importClassesFrom sp SpatialPoints
#'
NULL
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Class definitions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' The \code{Centroids} Class
#'
#' @slot cells (\code{\link[base:character]{character [n]}}) A vector of cell
#' names; there should be as many cell names as there are points and no
#' duplicate names
#' @slot nsides (\code{\link[base:integer]{integer [1L]}}) The number of sides
#' to draw when plotting centroids; must be either \code{0L} for circles or
#' greater than 3
#' @slot radius (\code{\link[base:numeric]{numeric [1L]}}) The radius of the
#' shape when plotting the centroids
#' @slot theta (\code{\link[base:numeric]{numeric [1L]}}) The angle in degrees
#' to adjust the shape when plotting the centroids
#'
#' @family segmentation
#' @templateVar cls Centroids
#' @template seealso-methods
#'
setClass(
Class = 'Centroids',
contains = 'SpatialPoints',
slots = list(
cells = 'character',
nsides = 'integer',
radius = 'numeric',
theta = 'numeric'
)
)
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Functions
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for Seurat-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' \code{Centroids} Methods
#'
#' Methods for \code{\link[SeuratObject:Centroids-class]{Centroids}} objects
#'
#' @param x,object A \code{\link[SeuratObject:Centroids-class]{Centroids}}
#' object
#' @param i,cells A vector of cells to keep; if \code{NULL}, defaults
#' to all cells
#' @param j,drop Ignored
#' @param ... Arguments passed to other methods
#'
#' @name Centroids-methods
#' @rdname Centroids-methods
#'
#' @seealso \code{\link{Centroids-class}}
#'
#' @family segmentation
#'
NULL
#'
#' @rdname Centroids-methods
#' @method Cells Centroids
#' @export
#'
Cells.Centroids <- function(x, ...) {
return(slot(object = x, name = 'cells'))
}
#' @importFrom sp SpatialPoints
#'
#' @method CreateCentroids default
#' @export
#'
CreateCentroids.default <- function(
coords,
nsides = Inf,
radius = NULL,
theta = 0L
) {
cnames <- c('x', 'y')
if (ncol(x = coords) >= 3) {
cnames <- append(x = cnames, values = 'cell')
}
idx <- NameIndex(x = coords, names = cnames, MARGIN = 2L)
cells <- if ('cell' %in% names(x = idx)) {
as.character(x = coords[, idx[['cell']], drop = TRUE])
} else {
rownames(x = coords)
}
coords <- as.matrix(x = coords[, idx[c('x', 'y'), drop = FALSE]])
colnames(x = coords) <- c('x', 'y')
rownames(x = coords) <- NULL
if (is.infinite(x = nsides)) {
nsides <- 0L
}
radius <- radius %||% .AutoRadius(coords = coords)
obj <- as(object = SpatialPoints(coords = coords), Class = 'Centroids')
slot(object = obj, name = 'cells') <- cells
slot(object = obj, name = 'nsides') <- as.integer(x = nsides)
slot(object = obj, name = 'radius') <- as.numeric(x = radius)
slot(object = obj, name = 'theta') <- as.numeric(x = theta)
validObject(object = obj)
return(obj)
}
#' @method CreateCentroids Centroids
#' @export
#'
CreateCentroids.Centroids <- function(
coords,
nsides = NULL,
radius = NULL,
theta = NULL
) {
return(CreateCentroids(
coords = GetTissueCoordinates(object = coords),
nsides = nsides %||% length(x = coords),
radius = radius %||% Radius(object = coords),
theta = theta %||% Theta(object = coords)
))
}
#' @method Crop Centroids
#' @export
#'
Crop.Centroids <- .Crop
#' @details \code{GetTissueCoordinates}: Get cell spatial coordinates
#'
#' @param full Expand the coordinates to the full polygon
#'
#' @return \code{GetTissueCoordinates}: A data frame with three columns:
#' \itemize{
#' \item \dQuote{\code{x}}: the x-coordinate
#' \item \dQuote{\code{y}}: the y-coordinate
#' \item \dQuote{\code{cell}}: the cell name
#' }
#' If \code{full} is \code{TRUE}, then each coordinate will indicate a vertex
#' for the cell polygon; otherwise, each coordinate will indicate a centroid
#' for the cell
#'
#' @importFrom sp coordinates
#'
#' @rdname Centroids-methods
#' @method GetTissueCoordinates Centroids
#' @export
#'
GetTissueCoordinates.Centroids <- function(object, full = TRUE, ...) {
coords <- as.data.frame(x = coordinates(obj = object))
colnames(x = coords) <- c('x', 'y')
coords$cell <- Cells(x = object)
if (isTRUE(x = full) && is.finite(x = object)) {
ct <- mapply(
FUN = PolyVtx,
xc = coords$x,
yc = coords$y,
MoreArgs = list(
n = length(x = object),
r = Radius(object = object),
t1 = Theta(object = object)
)
)
xt <- vector(mode = 'list', length = length(x = ct) / 2L)
xi <- 1L
for (i in seq.int(from = 1L, to = length(x = ct), by = 2L)) {
xt[[xi]] <- data.frame(
x = ct[[i]],
y = ct[[i + 1L]],
cell = coords$cell[xi],
stringsAsFactors = FALSE
)
xi <- xi + 1L
}
coords <- do.call(what = 'rbind', args = xt)
}
return(coords)
}
#' @details \code{Radius}: Get the centroid radius
#'
#' @return \code{Radius} The radius of the centroids
#'
#' @rdname Centroids-methods
#' @method Radius Centroids
#' @export
#'
Radius.Centroids <- function(object, ...) {
return(slot(object = object, name = 'radius'))
}
#' @details \code{RenameCells}: Update cell names
#'
#' @inheritParams RenameCells
#'
#' @return \code{RenameCells}: \code{object} with the cells renamed to
#' \code{new.names}
#'
#' @rdname Centroids-methods
#' @method RenameCells Centroids
#' @export
#'
RenameCells.Centroids <- function(object, new.names = NULL, ...) {
if (is.null(x = new.names)) {
return(object)
}
new.names <- make.unique(names = new.names)
if (length(x = new.names) != length(x = Cells(x = object))) {
stop("Cannot partially rename centroid cells", call. = FALSE)
}
slot(object = object, name = 'cells') <- new.names
return(object)
}
#' @details \code{Theta}: Get the offset angle
#'
#' @return \code{Theta}: The offset angle in degrees
#'
#' @rdname Centroids-methods
#' @method Theta Centroids
#' @export
#'
Theta.Centroids <- function(object) {
return(slot(object = object, name = 'theta'))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Methods for R-defined generics
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @details \code{is.finite}, \code{is.infinite}: Test to see if the centroids
#' are circular or polygonal
#'
#' @return \code{is.finite}: \code{TRUE} if the centroids are polygonal,
#' \code{FALSE} if circular
#'
#' @rdname Centroids-methods
#' @method is.finite Centroids
#' @export
#'
is.finite.Centroids <- .FiniteCentroids
#' @return \code{is.infinite}: The opposite of \code{is.finite}
#'
#' @rdname Centroids-methods
#' @method is.infinite Centroids
#' @export
#'
is.infinite.Centroids <- Negate(f = .FiniteCentroids)
#' @details \code{length}: Get the number of sides for the polygonal centroid
#'
#' @return \code{length}: \code{0} if the centroids are circular, otherwise the
#' number of sides of the polygonal centroid
#'
#' @rdname Centroids-methods
#' @method length Centroids
#' @export
#'
length.Centroids <- function(x) {
return(slot(object = x, name = 'nsides'))
}
#' @template method-lengths
#'
#' @rdname Centroids-methods
#' @method lengths Centroids
#' @export
#'
lengths.Centroids <- function(x, use.names = TRUE) {
return(rle(x = Cells(x = x)))
}
#' @details \code{subset}, \code{[}: Subset a \code{Centroids} object to
#' certain cells
#'
#' @return \code{subset}, \code{[}: \code{x} subsetted to the cells specified
#' by \code{cells}/\code{i}
#'
#' @rdname Centroids-methods
#' @method subset Centroids
#' @export
#'
subset.Centroids <- function(x, cells = NULL, ...) {
args <- list(...)
if (is.null(x = cells)) {
return(x)
}
if (is.numeric(x = cells)) {
cells <- Cells(x = x)[cells]
cells <- cells[!is.na(x = cells)]
}
cells <- MatchCells(new = Cells(x = x), orig = cells, ordered = TRUE)
if (!length(x = cells)) {
stop("None of the requested cells found")
}
return(CreateCentroids(
coords = GetTissueCoordinates(object = x)[cells, ],
nsides = args$nsides %||% length(x = x),
radius = args$radius %||% Radius(object = x),
theta = args$theta %||% Theta(object = x)
))
}
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# Internal
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
# S4 methods
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#' @rdname Centroids-methods
#'
setMethod(
f = '[',
signature = c(x = 'Centroids', i = 'character'),
definition = function(x, i, j, ..., drop = TRUE) {
i <- MatchCells(new = Cells(x = x), orig = i, ordered = TRUE)
return(x[i, drop = drop, ...])
}
)
#' @rdname Centroids-methods
#'
setMethod(
f = '[',
signature = c(x = 'Centroids', i = 'numeric'),
definition = function(x, i, j, ..., drop = TRUE) {
info <- list(
nsides = length(x = x),
radius = Radius(object = x),
theta = Theta(object = x)
)
cells <- Cells(x = x)[i]
cells <- cells[!is.na(x = cells)]
x <- callNextMethod()
for (n in names(x = info)) {
slot(object = x, name = n) <- info[[n]]
}
slot(object = x, name = 'cells') <- cells
validObject(object = x)
return(x)
}
)
setMethod(
f = 'over',
signature = c(x = 'Centroids', y = 'SpatialPolygons'),
definition = function(x, y, returnList = FALSE, fn = NULL, ...) {
deprecate_stop(
when = '5.0.0',
what = 'over()',
details = "Future integration with `sf` is on the roadmap with no current ETA"
)
check_installed(pkg = 'sf')
return(over(
x = as(object = x, Class = 'sf'),
y = as(object = y, Class = 'sf'),
returnList = returnList,
fn = fn,
...
))
}
)
#' @rdname Overlay
#' @export
#'
setMethod(
f = 'Overlay',
signature = c(x = 'Centroids', y = 'SpatialPolygons'),
definition = function(x, y, invert = FALSE, ...) {
check_installed(pkg = 'sf', reason = 'to overlay spatial information')
idx <- sf::st_intersects(
x = as(object = x, Class = 'sf'),
y = as(object = y, Class = 'sf'),
sparse = FALSE
)
idx <- which(idx)
names_in_sf_object1 <- if (!is.null(x = row.names(x = x))) {
row.names(x = x)[idx]
} else {
x$id[idx]
}
idx <- setNames(
object = rep(x = TRUE, length(x = idx)),
nm = names_in_sf_object1
)
if (!length(x = idx)) {
warn(message = "The selected region does not contain any cell centroids")
return(NULL)
}
idx <- sort(x = as.integer(x = names(x = idx)))
if (isTRUE(x = invert)) {
idx <- -idx
}
return(x[idx])
}
)
#' @template method-show
#'
#' @rdname Centroids-methods
#'
setMethod(
f = 'show',
signature = c(object = 'Centroids'),
definition = function(object) {
cat("Spatial centroids for", length(x = Cells(x = object)), "cells\n")
cat(
"",
ifelse(
test = length(x = object) == 0L,
yes = "Circular",
no = paste0(length(x = object), '-sided')
),
"spots\n"
)
cat(" Radius:", Radius(object = object), '\n')
cat(" Offset angle:", Theta(object = object), "degrees\n")
return(invisible(x = NULL))
}
)
setValidity(
Class = 'Centroids',
method = function(object) {
if (isFALSE(x = getOption(x = "Seurat.object.validate", default = TRUE))) {
warn(
message = paste("Not validating", class(x = object)[1L], "objects"),
class = 'validationWarning'
)
return(TRUE)
}
valid <- NULL
# Check cell names
cells <- Cells(x = object)
ucells <- Filter(f = nchar, x = unique(x = cells))
if (length(x = ucells) != length(x = cells)) {
valid <- c(
valid,
"'cells' must be a vector of unique cell names with one name for every coordinate"
)
}
if (length(x = cells) != nrow(x = slot(object = object, name = 'coords'))) {
valid <- c(
valid,
"the length of 'cells' must equal the number of rows in 'coords'"
)
}
if (!is.null(x = rownames(x = slot(object = object, name = 'coords')))) {
valid <- c(valid, "'coords' must not have any rownames")
}
# Check nsides
nsides <- length(x = object)
if (nsides < 0L || nsides %in% seq.int(from = 1L, to = 2L)) {
valid <- c(
valid,
"'nsides' must be either 0 or greater than or equal to 3"
)
}
# Check radius
if (Radius(object = object) <= 0) {
valid <- c(valid, "'radius' must be greater than 0")
}
# Check theta
theta <- Theta(object = object)
if (theta < 0 || theta > 360) {
valid <- c(valid, "'theta must be between 0 and 360")
}
return(valid %||% TRUE)
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.