indx = sort_index(d);
w = reorder_rows(w, indx);
d = reorder(d, indx);
h = reorder_rows(h, indx);
return Rcpp::List::create(
Rcpp::Named("w") = w.transpose(),
Rcpp::Named("d") = d,
Rcpp::Named("h") = h);
}
================================================
FILE: tests/testthat/test-SPOTlight-steps.R
================================================
library(SPOTlight)
library(SingleCellExperiment)
# library(RcppML)
set.seed(321)
# mock up some single-cell, mixture & marker data
sce <- mockSC(ng = 200, nc = 10, nt = 3)
spe <- mockSP(sce)
mgs <- getMGS(sce)
# Function to run the checks
.checks <- function(decon, sce) {
mtr <- decon[[1]]
rss <- decon[[2]]
expect_is(decon, "list")
expect_is(mtr, "matrix")
expect_is(rss, "numeric")
expect_identical(ncol(mtr), length(unique(sce$type)))
expect_identical(nrow(mtr), length(rss))
}
###############################
#### Run SPOTlight wrapper ####
###############################
set.seed(687)
res1 <- SPOTlight(
x = counts(sce),
y = counts(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene",
pnmf = "NMF"
)
################################
#### Run SPOTlight by steps ####
################################
set.seed(687)
# Train NMF
mod_ls <- trainNMF(
x = counts(sce),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
res2 <- runDeconvolution(
x = spe,
mod = mod_ls[["mod"]],
ref = mod_ls[["topic"]]
)
# NMF ----
test_that("SPOTlight vs SPOTlight-steps", {
# basis and coef should be the same between SPOTlight and SPOTlight-steps
expect_true(all(res1[["NMF"]]$w == mod_ls[["mod"]]$w))
expect_true(all(res1[["NMF"]]$h == res2[["NMF"]]$h))
# Deconvolution results are the same
# expect_true(all(res1[["mat"]] == res2[["mat"]]))
expect_true(mean(abs(res1[["mat"]] - res2[["mat"]])) < 0.01)
# actually check the estimates are legit
# (MSE < 0.1 compared to simulated truth)
sim <- S4Vectors::metadata(spe)[[1]]
mse <- mean((res2[["mat"]] - sim)^2)
expect_true(mse < 0.01)
})
================================================
FILE: tests/testthat/test-SPOTlight.R
================================================
set.seed(321)
# mock up some single-cell, mixture & marker data
sce <- mockSC(ng = 200, nc = 10, nt = 3)
spe <- mockSP(sce)
mgs <- getMGS(sce)
# Create SpatialExperiment
spe1 <- SpatialExperiment::SpatialExperiment(
assay = list(counts = SingleCellExperiment::counts(spe)),
colData = SummarizedExperiment::colData(spe))
# Function to run the checks
.checks <- function(res, sce) {
mtr <- res[[1]]
rss <- res[[2]]
mod <- res[[3]]
expect_is(res, "list")
expect_is(mtr, "matrix")
expect_is(rss, "numeric")
expect_is(mod, "list")
expect_identical(ncol(mtr), length(unique(sce$type)))
expect_identical(sort(colnames(mtr)), sort(unique(as.character(sce$type))))
expect_identical(nrow(mtr), length(rss))
expect_identical(sort(rownames(mtr)), sort(names(rss)))
}
# .checks <- function(res, sce) {
# mod <- res[[1]]
# mtr <- res[[2]]
# expect_is(res, "list")
# expect_is(mtr, "matrix")
# expect_is(mod, "list")
# expect_identical(ncol(mtr), length(unique(sce$type)))
# expect_identical(nrow(mtr), ncol(mod$w))
# expect_identical(nrow(mtr), nrow(mod$h))
# }
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# ---- Check SPOTlight x, y inputs -------------------------------------------
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# .SPOTlight with SCE ----
test_that("SPOTlight x SCE rcpp", {
res <- SPOTlight(
x = sce,
y = as.matrix(counts(spe)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with SPE ----
test_that("SPOTlight x SCE spatial rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = spe,
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with SPE ----
test_that("SPOTlight x SCE spatial rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = spe1,
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with sparse matrix sc ----
test_that("SPOTlight x dgCMatrix SC rcpp", {
res <- SPOTlight(
x = Matrix::Matrix(counts(sce), sparse = TRUE),
y = as.matrix(counts(spe)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with sparse matrix sp ----
test_that("SPOTlight x dgCMatrix SP rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = Matrix::Matrix(counts(spe), sparse = TRUE),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with sparse matrix sc ----
test_that("SPOTlight x DelayedMatrix SC rcpp", {
res <- SPOTlight(
x = DelayedArray::DelayedArray(counts(sce)),
y = as.matrix(counts(spe)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with sparse matrix sp ----
test_that("SPOTlight x DelayedMatrix SP rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = DelayedArray::DelayedArray(counts(sce)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with matrices in both ----
test_that("SPOTlight x matrices rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = as.matrix(counts(spe)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
})
# .SPOTlight with matrices in both and HVG----
test_that("SPOTlight x hvg rcpp", {
res <- SPOTlight(
x = as.matrix(counts(sce)),
y = as.matrix(counts(spe)),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene",
hvg = row.names(sce)[seq_len(50)]
)
.checks(res, sce)
})
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# ---- Check SPOTlight x, y inputs with NMF ----------------------------------
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# .SPOTlight with SCE ----
# test_that("SPOTlight x SCE NMF", {
# res <- SPOTlight(
# x = sce,
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with SPE ----
# test_that("SPOTlight x SCE spatial NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = spe,
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with SPE ----
# test_that("SPOTlight x SCE spatial NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = spe1,
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with Seurat SC ----
# test_that("SPOTlight x SEC NMF", {
# res <- SPOTlight(
# x = sec,
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with Seurat SP ----
# test_that("SPOTlight x SEP NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = spe,
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with sparse matrix sc ----
# test_that("SPOTlight x dgCMatrix SC NMF", {
# res <- SPOTlight(
# x = Matrix::Matrix(counts(sce), sparse = TRUE),
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
# .checks(res, sce)
# })
#
# # .SPOTlight with sparse matrix sp ----
# test_that("SPOTlight x dgCMatrix SP NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = Matrix::Matrix(counts(spe), sparse = TRUE),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with sparse matrix sc ----
# test_that("SPOTlight x DelayedMatrix SC NMF", {
# res <- SPOTlight(
# x = DelayedArray::DelayedArray(counts(sce)),
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
# .checks(res, sce)
# })
#
# # .SPOTlight with sparse matrix sp ----
# test_that("SPOTlight x DelayedMatrix SP NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = DelayedArray::DelayedArray(counts(sce)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with matrices in both ----
# test_that("SPOTlight x matrices NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # .SPOTlight with matrices in both and HVG----
# test_that("SPOTlight x hvg NMF", {
# res <- SPOTlight(
# x = as.matrix(counts(sce)),
# y = as.matrix(counts(spe)),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene",
# hvg = row.names(sce)[seq_len(50)]
# )
#
# .checks(res, sce)
# })
#
================================================
FILE: tests/testthat/test-plotCorrelationMatrix.R
================================================
set.seed(321)
x <- replicate(m <- 25, runif(10, 0, 1))
# Add an anticorrelated column
x[, 24] <- seq(0, 1, length.out = 10)
x[, 25] <- seq(1, 0, length.out = 10)
rownames(x) <- paste0("spot", seq_len(nrow(x)))
colnames(x) <- paste0("type", seq_len(ncol(x)))
.checks <- function(p) {
expect_is(p, "ggplot")
expect_true(all(p$data$p >= 0))
expect_true(all(p$data$p <= 1))
expect_true(is.numeric(p$data$value))
expect_true(max(p$data$value) == 1)
expect_true(nrow(p$data) == m * m)
}
# plotCorrelationMatrix basic ----
test_that("plotCorrelationMatrix basic", {
# The most basic example
p <- plotCorrelationMatrix(x = x)
.checks(p)
})
# plotCorrelationMatrix() spearman correlation ----
test_that("plotCorrelationMatrix() spearman", {
# The most basic example
p <- plotCorrelationMatrix(
x = x,
cor.method = "kendall"
)
.checks(p)
})
# plotCorrelationMatrix() ----
test_that("plotCorrelationMatrix() insig", {
# The most basic example
p <- plotCorrelationMatrix(
x = x,
insig = "pch"
)
.checks(p)
# This adds an extra layer with the X on top of the insig
expect_true(length(p$layers) == 2)
})
# plotCorrelationMatrix() colors ----
test_that("plotCorrelationMatrix() colors", {
# The most basic example
p <- plotCorrelationMatrix(
x = x,
colors = c("#FF00FF", "#FFFFFF", "#000000")
)
.checks(p)
g <- ggplot_build(p)
# max color
i <- which(p$data$value == max(p$data$value))[[1]]
expect_identical(g$data[[1]][i, ][, "fill"], "#000000")
# 0 color
j <- which(p$data$value == 0)[[1]]
expect_identical(g$data[[1]][j, ][, "fill"], "#FFFFFF")
# min color
k <- which(p$data$value == min(p$data$value))[[1]]
expect_identical(g$data[[1]][k, ][, "fill"], "#FF00FF")
})
# plotCorrelationMatrix() hc.order ----
test_that("plotCorrelationMatrix() hc.order", {
# The most basic example
p <- plotCorrelationMatrix(
x = x,
hc.order = FALSE
)
.checks(p)
# Make sure the order is no changed
expect_equal(as.character(p$data$Var1[seq_len(ncol(x))]), colnames(x))
})
# plotCorrelationMatrix() p.mat ----
test_that("plotCorrelationMatrix() p.mat", {
# The most basic example
p <- plotCorrelationMatrix(
x = x,
p.mat = FALSE
)
# Make sure the p value is not computed
expect_is(p, "ggplot")
expect_true(is.numeric(p$data$value))
expect_true(max(p$data$value) == 1)
expect_true(nrow(p$data) == m * m)
expect_true(all(is.na(p$data$pvalue)))
expect_true(all(is.na(p$data$signif)))
})
================================================
FILE: tests/testthat/test-plotImage.R
================================================
set.seed(321)
# x_path <- paste0(system.file(package = "SPOTlight"), "/extdata/image.png")
# x_path <- "../../inst/extdata/SPOTlight.png"
x_path <- paste0(system.file(package = "SPOTlight"), "/extdata/SPOTlight.png")
# plotImage() ----
test_that("plotImage path", {
# image
x <- x_path
plt <- plotImage(x = x)
expect_true(is_ggplot(plt))
})
# plotImage() ----
test_that("plotImage array", {
# image
x <- png::readPNG(x_path)
plt <- plotImage(x = x)
expect_true(is_ggplot(plt))
})
# Can't run this on Bioconductor since it doesn't accept github packages
# test_that("plotImage Seurat", {
# # if (!"SeuratData" %in% installed.packages()) {
# # devtools::install_github("satijalab/seurat-data")
# # }
# # image
# if (!"stxBrain.SeuratData" %in% suppressWarnings(SeuratData::InstalledData()$Dataset))
# suppressWarnings(SeuratData::InstallData(ds = "stxBrain.SeuratData"))
#
# x <- suppressWarnings(SeuratData::LoadData(
# ds = "stxBrain",
# type = "anterior1"))
#
# plt <- plotImage(x = x)
# expect_equal(class(plt)[1], "gg")
# })
test_that("plotImage SPE", {
# image
library(ExperimentHub)
eh <- ExperimentHub() # initialize hub instance
q <- query(eh, "TENxVisium") # retrieve 'TENxVisiumData' records
id <- q$ah_id[1] # specify dataset ID to load
x <- eh[[id]]
plt <- plotImage(x = x)
expect_true(is_ggplot(plt))
})
================================================
FILE: tests/testthat/test-plotInteractions.R
================================================
# helper to record base R plot
# plotNetwork() ----
# record base R plot
. <- \(.) {
pdf(NULL)
dev.control(displaylist = "enable")
set.seed(1)
.
. <- recordPlot()
invisible(dev.off())
return(.)
}
# mock up some data
set.seed(321)
x <- replicate(m <- 10, rnorm(n <- 100, runif(1, -1, 1)))
# Add columns to check characteristics of interest
x[, 8] <- 1
x[, 9] <- 1
x[, 10] <- -1
test_that("plotInteractions(), which = 'heatmap', metric = default", {
p <- plotInteractions(x, "heatmap")
expect_is(p, "ggplot")
expect_true(all(p$data$p >= 0))
expect_true(all(p$data$p <= 1))
expect_true(is.integer(p$data$n))
expect_true(nrow(p$data) == m * (m - 1) / 2)
})
test_that("plotInteractions(), which = 'heatmap', metric = 'jaccard'", {
p <- plotInteractions(x, "heatmap", "jaccard")
expect_is(p, "ggplot")
expect_true(all(p$data$p >= 0))
expect_true(all(p$data$p <= 1))
expect_true(is.integer(p$data$n))
expect_true(nrow(p$data) == m * (m - 1) / 2)
})
test_that("plotInteractions(), which = 'heatmap', tunning", {
p <- plotInteractions(x, "heatmap") +
scale_fill_gradient(low = "#FFFF00", high = "#FF0000")
# Same base checks
expect_is(p, "ggplot")
expect_true(all(p$data$p >= 0))
expect_true(all(p$data$p <= 1))
expect_true(is.integer(p$data$n))
expect_true(nrow(p$data) == m * (m - 1) / 2)
# Color checks
g <- ggplot_build(p)
d1 <- g$data[[1]]
d2 <- g$data[[2]]
# Access through tiles coordinates
# min <- d1[d1$x == max(d1$x) & d1$y == max(d1$y), "fill"]
# expect_equal(min, "#FFFF00")
expect_true("#FFFF00" %in% d1$fill)
# max <- d1[d1$x == 7 & d1$y == 1, "fill"]
# expect_equal(max, "#FF0000")
expect_true("#FF0000" %in% d1$fill)
# na <- d2[d2$x == 2 & d2$y == 1, "fill"]
# expect_equal(na, "grey50")
expect_true("grey50" %in% d2$fill)
})
test_that("plotInteractions(), which = 'network', metric = 'default'", {
p <- .(plotInteractions(x, "network"))
expect_is(p, "recordedplot")
p[[1]][[6]][[2]]$col
})
test_that("plotInteractions(), which = 'network', metric = 'jaccard'", {
p <- .(plotInteractions(x, "network", "jaccard"))
expect_is(p, "recordedplot")
p[[1]][[6]][[2]]$col
})
test_that("plotInteractions(), which = 'network', tunning", {
p <- .(plotInteractions(
x,
which = "network",
edge.color = "cyan",
vertex.color = "pink",
vertex.label.font = 2,
vertex.label.color = "maroon"
))
expect_is(p, "recordedplot")
# Test edge color
expect_equal(p[[1]][[6]][[2]]$col, "cyan")
# Vertex label color and font
# expect_equal(p[[1]][[10]][[2]][[9]], "maroon")
# expect_equal(p[[1]][[10]][[2]][[10]], 2)
# Vertex color
# expect_equal(p[[1]][[8]][[2]][[7]], "pink")
})
================================================
FILE: tests/testthat/test-plotSpatialScatterpie.R
================================================
set.seed(321)
# Coordinates
x <- matrix(nrow = 10, data = c(seq_len(10), 10:1))
rownames(x) <- paste0("spot", seq_len(nrow(x)))
colnames(x) <- c("coord_x", "coord_y")
# Proportions
y <- replicate(m <- 5, runif(10, 0, 1))
y <- y / rowSums(y)
rownames(y) <- paste0("spot", seq_len(nrow(y)))
colnames(y) <- paste0("type", seq_len(ncol(y)))
# image
img <- paste0(system.file(package = "SPOTlight"), "/extdata/SPOTlight.png")
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie with matrix and bad colnames", {
plt <- plotSpatialScatterpie(
x = x,
y = y
)
expect_true(is_ggplot(plt))
})
colnames(x) <- c("imagecol", "imagerow")
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie with matrix and bad colnames", {
plt <- plotSpatialScatterpie(
x = x,
y = y
)
expect_true(is_ggplot(plt))
})
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie - image", {
plt <- plotSpatialScatterpie(
x = x,
y = y,
img = img
)
expect_true(is_ggplot(plt))
})
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie - type subset", {
plt <- plotSpatialScatterpie(
x = x,
y = y,
cell_types = colnames(y)[seq_len(3)]
)
expect_true(is_ggplot(plt))
})
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie - alpha", {
plt <- plotSpatialScatterpie(
x = x,
y = y,
scatterpie_alpha = 0.5
)
expect_true(is_ggplot(plt))
expect_lt(plt$layers[[1]]$aes_params$alpha, 1)
})
# plotSpatialScatterpie() ----
test_that("plotSpatialScatterpie - pie_scale", {
plt <- plotSpatialScatterpie(
x = x,
y = y,
pie_scale = 0.1
)
expect_true(is_ggplot(plt))
})
library(SpatialExperiment)
example(read10xVisium, echo = FALSE)
# Proportions
spe_y <- replicate(m <- 5, runif(ncol(spe), 0, 1))
spe_y <- spe_y / rowSums(spe_y)
rownames(spe_y) <- colnames(spe)
colnames(spe_y) <- paste0("type", seq_len(ncol(spe_y)))
# plotSpatialScatterpie() img TRUE----
test_that("plotSpatialScatterpie - image", {
plt <- plotSpatialScatterpie(
x = spe,
y = spe_y,
img = TRUE
)
expect_true(is_ggplot(plt))
# Make sure there is an image
expect_true(is(plt$layers[[1]]$geom, "GeomCustomAnn"))
})
# plotSpatialScatterpie() img TRUE----
test_that("plotSpatialScatterpie - spots on image", {
plt <- plotSpatialScatterpie(
x = spe,
y = spe_y,
img = TRUE
)
expect_true(is_ggplot(plt))
# Make sure there is an image
expect_true(is(plt$layers[[1]]$geom, "GeomCustomAnn"))
# Check the spots are on within the image coordinates
x_y_min_max <- plt$layers[[1]]$geom_params
point_df <- plt$layers[[2]]$data
expect_true(max(point_df$coord_x) <= x_y_min_max$xmax)
expect_true(min(point_df$coord_x) >= x_y_min_max$xmin)
expect_true(max(point_df$coord_y) <= x_y_min_max$ymax)
expect_true(min(point_df$coord_y) >= x_y_min_max$ymin)
})
================================================
FILE: tests/testthat/test-plotTopicProfiles.R
================================================
set.seed(123)
x <- mockSC(nc = 50, nt = 3)
y <- mockSP(x)
z <- getMGS(x)
res <- SPOTlight(
x,
y,
groups = x$type,
mgs = z,
group_id = "type",
verbose = FALSE)
test_that("plotTopicProfiles common", {
p <- plotTopicProfiles(x = res[[3]], y = x$type, facet = FALSE, min_prop = 0.1)
expect_is(p, "ggplot")
expect_equal(nrow(p$data), 9)
expect_equal(sort(unique(p$data$group)), as.character(sort(unique(x$type))))
expect_equal(ncol(p$data), 3)
expect_equal(
as.character(sort(unique(p$data$topic))),
as.character(seq_len(length(unique(x$type)))))
g <- ggplot_build(p)
expect_true(all(c("#3D2BFF", "#D3D3D3") %in% unique(g$data[[1]]$colour)))
})
test_that("plotTopicProfiles facet", {
p <- plotTopicProfiles(res[[3]], x$type, facet = TRUE, min_prop = 0.1)
expect_is(p, "ggplot")
expect_equal(nrow(p$data), 160)
expect_equal(ncol(p$data), 4)
g <- ggplot_build(p)
expect_true(all(c("#3D2BFF", "#4931FE", "#D3D3D3") %in% unique(g$data[[1]]$colour)))
})
================================================
FILE: tests/testthat/test-runDeconvolution.R
================================================
set.seed(321)
# mock up some single-cell, mixture & marker data
sce <- mockSC(ng = 200, nc = 10, nt = 3)
spe <- mockSP(sce)
mgs <- getMGS(sce)
# Create SpatialExperiment
spe1 <- SpatialExperiment::SpatialExperiment(
assay = list(counts = SingleCellExperiment::counts(spe)),
colData = SummarizedExperiment::colData(spe))
# Function to run the checks
.checks <- function(decon, sce, spe) {
mtr <- decon[[1]]
rss <- decon[[2]]
expect_is(decon, "list")
expect_is(mtr, "matrix")
expect_is(rss, "numeric")
expect_identical(ncol(mtr), length(unique(sce$type)))
expect_identical(sort(colnames(mtr)), sort(unique(as.character(sce$type))))
expect_identical(nrow(mtr), length(rss))
expect_identical(sort(rownames(mtr)), sort(names(rss)))
dif <- rowSums((mtr - metadata(spe)$props)^2)
median_ss <- median(dif)
mean_ss <- mean(dif)
expect_true(mean_ss < 0.1 & median_ss < 0.1)
}
# Train NMF
res <- trainNMF(
x = as.matrix(counts(sce)),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# ---- Check runDeconvolution x, y inputs ------------------------------------
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# runDeconvolution with SCE ----
test_that("runDeconvolution x SCE", {
decon <- runDeconvolution(
x = spe,
mod = res[["mod"]],
ref = res[["topic"]]
)
.checks(decon, sce, spe)
})
test_that("runDeconvolution x SPE", {
decon <- runDeconvolution(
x = spe1,
mod = res[["mod"]],
ref = res[["topic"]]
)
.checks(decon, sce, spe)
})
# runDeconvolution with sparse matrix sp ----
test_that("runDeconvolution x dgCMatrix SP", {
decon <- runDeconvolution(
x = Matrix::Matrix(counts(spe), sparse = TRUE),
mod = res[["mod"]],
ref = res[["topic"]]
)
.checks(decon, sce, spe)
})
# runDeconvolution with sparse matrix sp ----
test_that("runDeconvolution x DelayedMatrix SP", {
decon <- runDeconvolution(
x = DelayedArray::DelayedArray(counts(spe)),
mod = res[["mod"]],
ref = res[["topic"]]
)
.checks(decon, sce, spe)
})
# runDeconvolution with matrices in both ----
test_that("runDeconvolution x matrices", {
decon <- runDeconvolution(
x = as.matrix(counts(spe)),
mod = res[["mod"]],
ref = res[["topic"]]
)
.checks(decon, sce, spe)
})
================================================
FILE: tests/testthat/test-trainNMF.R
================================================
set.seed(321)
# mock up some single-cell, mixture & marker data
sce <- mockSC(ng = 200, nc = 10, nt = 3)
spe <- mockSP(sce)
mgs <- getMGS(sce)
.checks <- function(res, sce) {
mod <- res[[1]]
mtr <- res[[2]]
expect_is(res, "list")
expect_is(mtr, "matrix")
expect_is(mod, "list")
expect_identical(ncol(mtr), length(unique(sce$type)))
expect_identical(nrow(mtr), ncol(mod$w))
expect_identical(nrow(mtr), nrow(mod$h))
}
# Unit test to verify that the topic with max weight in each cell aligns with type
.check_topic_alignment <- function(mod_h, topic) {
cell_pos <- c(1, 11, 21)
type_names <- rownames(topic)[1:3] # types 1 to 3
for (i in seq_along(cell_pos)) {
cell <- cell_pos[i]
type <- type_names[i]
expect_equal(which.max(mod_h[, cell]), which.max(topic[type, ]))
}
}
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# ---- Check RCPP trainNMF x, y inputs -------------------------------------------
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# trainNMF with SCE ----
test_that("rcpp trainNMF x SCE", {
set.seed(321)
res <- trainNMF(
x = sce,
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
.check_topic_alignment(res$mod$h, res$topic)
})
# trainNMF with sparse matrix sc ----
test_that("rcpp trainNMF x dgCMatrix SC", {
set.seed(321)
res <- trainNMF(
x = Matrix::Matrix(counts(sce), sparse = TRUE),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
.check_topic_alignment(res$mod$h, res$topic)
})
# trainNMF with sparse matrix sc ----
test_that("rcpp trainNMF x DelayedMatrix SC", {
set.seed(321)
res <- trainNMF(
x = DelayedArray::DelayedArray(counts(sce)),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
.check_topic_alignment(res$mod$h, res$topic)
})
# trainNMF with matrices in both ----
test_that("rcpp trainNMF x matrices", {
set.seed(321)
res <- trainNMF(
x = as.matrix(counts(sce)),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene"
)
.checks(res, sce)
.check_topic_alignment(res$mod$h, res$topic)
})
# trainNMF with matrices in both and HVG----
test_that("rcpp trainNMF x hvg", {
set.seed(321)
res <- trainNMF(
x = as.matrix(counts(sce)),
y = rownames(spe),
groups = sce$type,
mgs = mgs,
weight_id = "weight",
group_id = "type",
gene_id = "gene",
hvg = row.names(sce)[seq_len(50)]
)
.checks(res, sce)
.check_topic_alignment(res$mod$h, res$topic)
})
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# ---- Check NMF::nmf trainNMF x, y inputs -------------------------------------------
# ------------------------------------------------------------------------------
# ------------------------------------------------------------------------------
# trainNMF with SCE ----
# test_that("NMF trainNMF x SCE", {
# res <- trainNMF(
# x = sce,
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # trainNMF with SPE ----
# test_that("NMF trainNMF x SEC", {
# res <- trainNMF(
# x = sec,
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # trainNMF with sparse matrix sc ----
# test_that("NMF trainNMF x dgCMatrix SC", {
# res <- trainNMF(
# x = Matrix::Matrix(counts(sce), sparse = TRUE),
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
# .checks(res, sce)
# })
#
# # trainNMF with sparse matrix sc ----
# test_that("NMF trainNMF x DelayedMatrix SC", {
# res <- trainNMF(
# x = DelayedArray::DelayedArray(counts(sce)),
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
# .checks(res, sce)
# })
#
# # trainNMF with matrices in both ----
# test_that("NMF trainNMF x matrices", {
# res <- trainNMF(
# x = as.matrix(counts(sce)),
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene"
# )
#
# .checks(res, sce)
# })
#
# # trainNMF with matrices in both and HVG----
# test_that("NMF trainNMF x hvg", {
# res <- trainNMF(
# x = as.matrix(counts(sce)),
# y = rownames(spe),
# groups = sce$type,
# pnmf = "NMF",
# mgs = mgs,
# weight_id = "weight",
# group_id = "type",
# gene_id = "gene",
# hvg = row.names(sce)[seq_len(50)]
# )
#
# .checks(res, sce)
# })
#
================================================
FILE: tests/testthat/test-utils.R
================================================
set.seed(321)
# mock up some single-cell, mixture & marker data
sce <- mockSC()
spe <- mockSP(sce)
mgs <- getMGS(sce)
# .scale_uv ----
test_that(".scale_uv()", {
x <- counts(sce)
y <- .scale_uv(x)
expect_is(y, "matrix")
expect_identical(dim(y), dim(x))
expect_identical(dimnames(y), dimnames(x))
expect_true(all(abs(1 - sparseMatrixStats::rowVars(y)) < 1e-12))
})
# default parameters
defs <- list(
gene_id = "gene",
group_id = "type",
weight_id = "weight",
verbose = FALSE
)
# NMF ----
test_that("NMF", {
x <- counts(sce)
y <- counts(spe)
groups <- sce$type
group_ids <- sort(unique(as.character(sce$type)))
n_groups <- length(group_ids)
# + trainNMF ----
# undetected genes should be filtered out
# and pass silently (i.e., without error)
i <- sample(rownames(x), 5)
j <- sample(rownames(y), 5)
x. <- x
x.[i, ] <- 0
y. <- y
y.[j, ] <- 0
args <- c(defs, list(x., rownames(y.), groups, mgs))
fit <- expect_silent(do.call(trainNMF, args))
mod <- fit[["mod"]]
expect_is(mod, "list")
expect_true(!all(c(i, j) %in% rownames(mod)))
# Only marker genes should be present - we don't use hvg here
expect_true(all(rownames(mod) %in% mgs$gene))
# valid call should give an object of class 'NMF'
# and dimension (#genes) x (#cells) x (#groups)
args <- c(defs, list(x, rownames(y), groups, mgs))
fit <- expect_silent(do.call(trainNMF, args))
mod <- fit[["mod"]]
expect_is(mod, "list")
# Remove genes since these can change depending on
# filtering, mgs, hvg, all 0...
expect_identical(
dimnames(mod$h)[1:2],
c(list(paste0("topic_", 1:nrow(mod$h))), dimnames(x)[2]))
expect_identical(
dimnames(mod$w)[1:2],
c(list(mgs$gene), list(paste0("topic_", 1:nrow(mod$h)))))
# + .topic_profiles ----
# should give a square numeric matrix
# of dimension (#groups) x (#groups)
ref <- .topic_profiles(mod, groups)
expect_is(ref, "matrix")
expect_equal(dim(ref), rep(n_groups, 2))
expect_identical(rownames(ref), group_ids)
expect_identical(colnames(ref), paste0("topic_", 1:nrow(ref)))
# + .pred_hp ----
fqs <- .pred_hp(x, mod)
expect_is(fqs, "matrix")
expect_true(is.numeric(x))
expect_true(all(fqs >= 0))
expect_equal(dim(fqs), c(n_groups, ncol(x)))
expect_identical(
dimnames(fqs),
list(paste0("topic_", 1:nrow(ref)), colnames(x)))
# + runDeconvolution ----
# should give a numeric matrix
# of dimension (#groups) x (#spots)
# with proportions (i.e., values in [0, 1])
res <- runDeconvolution(x = y, mod = mod, ref = ref)
mat <- res[[1]]
err <- res[[2]]
expect_is(mat, "matrix")
expect_true(is.numeric(err))
expect_true(is.numeric(x))
expect_true(all(mat >= 0 & mat <= 1))
expect_true(all(rowSums(mat) - 1 < 1e-12))
expect_identical(dimnames(mat), list(colnames(y), group_ids))
expect_identical(rownames(mat), names(err))
# actually check the estimates are legit
# (MSE < 0.1 compared to simulated truth)
sim <- S4Vectors::metadata(spe)[[1]]
mse <- mean((mat - sim)^2)
expect_true(mse < 0.2)
})
# image
library(ExperimentHub)
eh <- ExperimentHub() # initialize hub instance
q <- query(eh, "TENxVisium") # retrieve 'TENxVisiumData' records
id <- q$ah_id[1] # specify dataset ID to load
spe <- eh[[id]]
colLabels(spe) <- spe$sample_id
# .extract_counts
test_that(".extract_counts()", {
x <- suppressWarnings(.extract_counts(spe, slot = "counts"))
expect_identical(dim(counts(spe)), dim(x))
expect_identical(dimnames(spe), dimnames(x))
})
# .scale_uv
test_that("scale_uv()", {
x <- counts(sce)
y <- .scale_uv(x)
expect_is(y, "matrix")
expect_identical(dim(y), dim(x))
expect_identical(dimnames(y), dimnames(x))
expect_true(all(abs(1 - rowVars(y)) < 1e-12))
})
# .plot_image
x_path <- paste0(system.file(package = "SPOTlight"), "/extdata/SPOTlight.png")
test_that(".plot_image() SPE", {
img <- .extract_image(x_path)
plt <- .plot_image(img)
expect_true(is.array(img))
expect_true(is_ggplot(plt))
})
test_that(".plot_image() SPE", {
img <- .extract_image(spe)
plt <- .plot_image(img)
expect_true(is_ggplot(plt))
expect_true(is.matrix(img))
})
================================================
FILE: tests/testthat.R
================================================
set.seed(321)
library(testthat)
library(SPOTlight)
# plotImage() ----
test_check("SPOTlight")
================================================
FILE: vignettes/SPOTlight_kidney.Rmd
================================================
---
title: "Spatial Transcriptomics Deconvolution with `SPOTlight`"
date: "`r BiocStyle::doc_date()`"
author:
- name: Marc Elosua-Bayes
affiliation:
- &CNAG-CRG National Center for Genomic Analysis - Center for Genomic Regulation
- &UPF University Pompeu Fabra
email: marc.elosua@cnag.crg.eu
- name: Helena L. Crowell
affiliation:
- &IMLS Institute for Molecular Life Sciences, University of Zurich, Switzerland
- &SIB SIB Swiss Institute of Bioinformatics, University of Zurich, Switzerland
email: helena.crowell@uzh.ch
- name: Zach DeBruine
affiliation:
- &VAI Van Andel Institue
email: Zach.DeBruine@vai.edu
abstract: >
Spatially resolved gene expression profiles are key to understand tissue organization and function. However, novel spatial transcriptomics (ST) profiling techniques lack single-cell resolution and require a combination with single-cell RNA sequencing (scRNA-seq) information to deconvolute the spatially indexed datasets. Leveraging the strengths of both data types, we developed SPOTlight, a computational tool that enables the integration of ST with scRNA-seq data to infer the location of cell types and states within a complex tissue. SPOTlight is centered around a seeded non-negative matrix factorization (NMF) regression, initialized using cell-type marker genes and non-negative least squares (NNLS) to subsequently deconvolute ST capture locations (spots).
package: "`r BiocStyle::pkg_ver('SPOTlight')`"
vignette: >
%\VignetteIndexEntry{"SPOTlight"}
%\VignettePackage{SPOTlight}
%\VignetteEncoding{UTF-8}
%\VignetteEngine{knitr::rmarkdown}
output:
BiocStyle::html_document
editor_options:
markdown:
wrap: 80
---
```{=html}
```
For a more detailed explanation of `SPOTlight` consider looking at our
manuscript:
> Elosua-Bayes M, Nieto P, Mereu E, Gut I, Heyn H.
SPOTlight: seeded NMF regression to deconvolute
spatial transcriptomics spots with single-cell transcriptomes.
*Nucleic Acids Res.* **2021;49(9):e50**. doi: [10.1093](10.1093/nar/gkab043)
# Load packages {.unnumbered}
```{r load-libs, message = FALSE, warning = FALSE}
library(ggplot2)
library(SPOTlight)
library(SingleCellExperiment)
library(SpatialExperiment)
library(scater)
library(scran)
```
# Introduction
## What is `SPOTlight`?
`SPOTlight` is a tool that enables the deconvolution of cell types and cell type
proportions present within each capture location comprising mixtures of cells.
Originally developed for 10X's Visium - spatial transcriptomics - technology, it
can be used for all technologies returning mixtures of cells.
`SPOTlight` is based on learning topic profile signatures, by means of an NMFreg
model, for each cell type and finding which combination of cell types fits best
the spot we want to deconvolute. Find below a graphical abstract visually
summarizing the key steps.
## Starting point
The minimal unit of data required to run `SPOTlight` are:
- ST (sparse) matrix with the expression, raw or normalized, where rows = genes
and columns = capture locations.
- Single cell (sparse) matrix with the expression, raw or normalized,
where rows = genes and columns = cells.
- Vector indicating the cell identity for each column in the single cell
expression matrix.
Data inputs can also be objects of class `r Biocpkg("SpatialExperiment")` (SE),
`r Biocpkg("SingleCellExperiment")` (SCE) objects from
which the minimal data will be extracted.
# Getting started
## Data description
For this vignette, we will use a SE put out by *10X Genomics* containing a
Visium kidney slide. The raw data can be accessed
[here](https://support.10xgenomics.com/spatial-gene-expression/datasets/1.1.0/V1_Mouse_Kidney).
SCE data comes from the [*The Tabula Muris
Consortium*](https://www.nature.com/articles/s41586-020-2496-1) which contains
\>350,000 cells from from male and female mice belonging to six age groups,
ranging from 1 to 30 months. From this dataset we will only load the kidney
subset to map it to the Visium slide.
## Loading the data
Both datasets are available through Biocondcutor packages and can be loaded into R as follows.
`
Load the spatial data:
```{r load-sp, message=FALSE}
library(TENxVisiumData)
spe <- MouseKidneyCoronal()
# Use symbols instead of Ensembl IDs as feature names
rownames(spe) <- rowData(spe)$symbol
```
Load the single cell data. Since our data comes from the
[Tabula Muris Sensis](https://www.nature.com/articles/s41586-020-2496-1)
dataset, we can directly load the SCE object as follows:
```{r load-sc, message=FALSE}
library(TabulaMurisSenisData)
sce <- TabulaMurisSenisDroplet(tissues = "Kidney")$Kidney
```
Quick data exploration:
```{r explo}
table(sce$free_annotation, sce$age)
```
We see how there is a good representation of all the cell types across ages
except at 24m. In order to reduce the potential noise introduced by age and
batch effects we are going to select cells all coming from the same age.
```{r sub-18m}
# Keep cells from 18m mice
sce <- sce[, sce$age == "18m"]
# Keep cells with clear cell type annotations
sce <- sce[, !sce$free_annotation %in% c("nan", "CD45")]
```
# Workflow
## Preprocessing
If the dataset is very large we want to downsample it to train the model, both
in of number of cells and number of genes. To do this, we want to keep a
representative amount of cells per cluster and the most biologically relevant
genes.
In the paper we show how downsampling the number of cells per cell identity to
\~100 doesn't affect the performance of the model. Including \>100 cells per
cell identity provides marginal improvement while greatly increasing
computational time and resources. Furthermore, restricting the gene set to the
marker genes for each cell type along with up to 3.000 highly variable genes
further optimizes performance and computational resources. You can find a more
detailed explanation in the original
[paper](https://academic.oup.com/nar/article/49/9/e50/6129341).
### Feature selection
Our first step is to get the marker genes for each cell type. We follow the
Normalization procedure as described in
[OSCA](http://bioconductor.org/books/3.14/OSCA.basic/normalization.html). We
first carry out library size normalization to correct for cell-specific biases:
```{r lognorm}
sce <- logNormCounts(sce)
```
### Variance modelling
We aim to identify highly variable genes that drive biological heterogeneity.
By feeding these genes to the model we improve the resolution of the biological structure and reduce the technical noise.
```{r variance}
# Get vector indicating which genes are neither ribosomal or mitochondrial
genes <- !grepl(pattern = "^Rp[l|s]|Mt", x = rownames(sce))
dec <- modelGeneVar(sce, subset.row = genes)
plot(dec$mean, dec$total, xlab = "Mean log-expression", ylab = "Variance")
curve(metadata(dec)$trend(x), col = "blue", add = TRUE)
# Get the top 3000 genes.
hvg <- getTopHVGs(dec, n = 3000)
```
Next we obtain the marker genes for each cell identity. You can use whichever
method you want as long as it returns a weight indicating the importance of that
gene for that cell type. Examples include `avgLogFC`, `AUC`, `pct.expressed`,
`p-value`...
```{r mgs}
colLabels(sce) <- colData(sce)$free_annotation
# Compute marker genes
mgs <- scoreMarkers(sce, subset.row = genes)
```
Then we want to keep only those genes that are relevant for each cell identity:
```{r mgs-df}
mgs_fil <- lapply(names(mgs), function(i) {
x <- mgs[[i]]
# Filter and keep relevant marker genes, those with AUC > 0.8
x <- x[x$mean.AUC > 0.8, ]
# Sort the genes from highest to lowest weight
x <- x[order(x$mean.AUC, decreasing = TRUE), ]
# Add gene and cluster id to the dataframe
x$gene <- rownames(x)
x$cluster <- i
data.frame(x)
})
mgs_df <- do.call(rbind, mgs_fil)
```
### Cell Downsampling
Next, we randomly select at most 100 cells per cell identity. If a cell type is
comprised of \<100 cells, all the cells will be used. If we have very
biologically different cell identities (B cells vs. T cells vs. Macrophages vs.
Epithelial) we can use fewer cells since their transcriptional profiles will be
very different. In cases when we have more transcriptionally similar cell
identities we need to increase our N to capture the biological heterogeneity
between them.
In our experience we have found that for this step it is better to select the
cells from each cell type from the same batch if you have a joint dataset from
multiple runs. This will ensure that the model removes as much signal from the
batch as possible and actually learns the biological signal.
For the purpose of this vignette and to speed up the analysis, we are going to
use 20 cells per cell identity:
```{r downsample}
# split cell indices by identity
idx <- split(seq(ncol(sce)), sce$free_annotation)
# downsample to at most 20 per identity & subset
# We are using 5 here to speed up the process but set to 75-100 for your real
# life analysis
n_cells <- 50
cs_keep <- lapply(idx, function(i) {
n <- length(i)
if (n < n_cells)
n_cells <- n
sample(i, n_cells)
})
sce <- sce[, unlist(cs_keep)]
```
## Deconvolution
You are now set to run `SPOTlight` to deconvolute the spots!
Briefly, here is how it works:
1. NMF is used to factorize a matrix into two lower dimensionality matrices
without negative elements. We first have an initial matrix V (SCE count matrix),
which is factored into W and H. Unit variance normalization by gene is performed
in V and in order to standardize discretized gene expression levels,
‘counts-umi’. Factorization is then carried out using the non-smooth NMF method,
implemented in the R package NMF `r CRANpkg("NMF")` (14). This method is
intended to return sparser results during the factorization in W and H, thus
promoting cell-type-specific topic profile and reducing overfitting during
training. Before running factorization, we initialize each topic, column,
of W with the unique marker genes for each cell type with weights. In turn, each
topic of H in `SPOTlight` is initialized with the corresponding membership of each
cell for each topic, 1 or 0. This way, we seed the model with prior information,
thus guiding it towards a biologically relevant result. This initialization also
aims at reducing variability and improving the consistency between runs. \
2. NNLS regression is used to map each capture location's transcriptome in V’
(SE count matrix) to H’ using W as the basis. We obtain a topic profile
distribution over each capture location which we can use to determine its
composition. \
3. we obtain Q, cell-type specific topic profiles, from H. We select all cells
from the same cell type and compute the median of each topic for a consensus
cell-type-specific topic signature. We then use NNLS to find the weights of each
cell type that best fit H’ minimizing the residuals.
You can visualize the above explanation in the following workflow scheme:
```{r SPOTlight}
res <- SPOTlight(
x = sce,
y = spe,
groups = as.character(sce$free_annotation),
mgs = mgs_df,
hvg = hvg,
weight_id = "mean.AUC",
group_id = "cluster",
gene_id = "gene")
```
Alternatively you can run `SPOTlight` in two steps so that you can have the trained model. Having the trained model allows you to reuse with other datasets you also want to deconvolute with the same reference. This allows you to skip the training step, the most time consuming and computationally expensive.
```{r SPOTlight2, eval=FALSE}
mod_ls <- trainNMF(
x = sce,
groups = sce$free_annotation,
mgs = mgs_df,
hvg = hvg,
weight_id = "mean.AUC",
group_id = "cluster",
gene_id = "gene")
# Run deconvolution
res <- runDeconvolution(
x = spe,
mod = mod_ls[["mod"]],
ref = mod_ls[["topic"]])
```
Extract data from `SPOTlight`:
```{r}
# Extract deconvolution matrix
head(mat <- res$mat)[, seq_len(3)]
# Extract NMF model fit
mod <- res$NMF
```
# Visualization
In the next section we show how to visualize the data and interpret
`SPOTlight`'s results.
## Topic profiles
We first take a look at the Topic profiles. By setting `facet = FALSE` we want to
evaluate how specific each topic signature is for each cell identity.
Ideally each cell identity will have a unique topic profile associated to it as
seen below.
```{r plotTopicProfiles1, fig.width=6, fig.height=7}
plotTopicProfiles(
x = mod,
y = sce$free_annotation,
facet = FALSE,
min_prop = 0.01,
ncol = 1) +
theme(aspect.ratio = 1)
```
Next we also want to ensure that all the cells from the same cell identity share
a similar topic profile since this will mean that `SPOTlight` has learned a
consistent signature for all the cells from the same cell identity.
```{r plotTopicProfiles2, fig.width=9, fig.height=6}
plotTopicProfiles(
x = mod,
y = sce$free_annotation,
facet = TRUE,
min_prop = 0.01,
ncol = 6)
```
Lastly we can take a look at which genes the model learned for each topic.
Higher values indicate that the gene is more relevant for that topic.
In the below table we can see how the top genes for `Topic1` are characteristic
for B cells (i.e. *Cd79a*, *Cd79b*, *Ms4a1*...).
```{r basis-dt, message=FALSE, warning=FALSE}
# library(NMF)
sign <- mod$w
# colnames(sign) <- paste0("Topic", seq_len(ncol(sign)))
head(sign)
# This can be dynamically visualized with DT as shown below
# DT::datatable(sign, fillContainer = TRUE, filter = "top")
```
## Spatial Correlation Matrix
See [here](http://www.sthda.com/english/wiki/ggcorrplot-visualization-of-a-correlation-matrix-using-ggplot2)
for additional graphical parameters.
```{r plotCorrelationMatrix, fig.width=9, fig.height=9}
plotCorrelationMatrix(mat)
```
## Co-localization
Now that we know which cell types are found within each spot we can make a graph
representing spatial interactions where cell types will have stronger edges
between them the more often we find them within the same spot.
See [here](https://www.r-graph-gallery.com/network.html) for additional
graphical parameters.
```{r plotInteractions, fig.width=9, fig.height=9}
plotInteractions(mat, which = "heatmap", metric = "prop")
plotInteractions(mat, which = "heatmap", metric = "jaccard")
plotInteractions(mat, which = "network")
```
## Scatterpie
We can also visualize the cell type proportions as sections of a pie chart for
each spot. You can modify the colors as you would a standard `r CRANpkg("ggplot2")`.
```{r Scatterpie, fig.width=9, fig.height=6}
ct <- colnames(mat)
mat[mat < 0.1] <- 0
# Define color palette
# (here we use 'paletteMartin' from the 'colorBlindness' package)
paletteMartin <- c(
"#000000", "#004949", "#009292", "#ff6db6", "#ffb6db",
"#490092", "#006ddb", "#b66dff", "#6db6ff", "#b6dbff",
"#920000", "#924900", "#db6d00", "#24ff24", "#ffff6d")
pal <- colorRampPalette(paletteMartin)(length(ct))
names(pal) <- ct
plotSpatialScatterpie(
x = spe,
y = mat,
cell_types = colnames(mat),
img = FALSE,
scatterpie_alpha = 1,
pie_scale = 0.4) +
scale_fill_manual(
values = pal,
breaks = names(pal))
```
With the image underneath - we are rotating it 90 degrees counterclockwise and mirroring across the horizontal axis to show how to align if the spots don't overlay the image.
```{r}
plotSpatialScatterpie(
x = spe,
y = mat,
cell_types = colnames(mat),
img = FALSE,
scatterpie_alpha = 1,
pie_scale = 0.4,
# Rotate the image 90 degrees counterclockwise
degrees = -90,
# Pivot the image on its x axis
axis = "h") +
scale_fill_manual(
values = pal,
breaks = names(pal))
```
## Residuals
Lastly we can also take a look at how well the model predicted the proportions
for each spot. We do this by looking at the residuals of the sum of squares for
each spot which indicates the amount of biological signal not explained by the model.
```{r message=FALSE}
spe$res_ss <- res[[2]][colnames(spe)]
xy <- spatialCoords(spe)
spe$x <- xy[, 1]
spe$y <- xy[, 2]
ggcells(spe, aes(x, y, color = res_ss)) +
geom_point() +
scale_color_viridis_c() +
coord_fixed() +
theme_bw()
```
# Session information
```{r session-info}
sessionInfo()
```
### We are currently on the process of submitting SPOTlight to bioconductor and there have been some styling changes on this branch compared to previous releases. If you want to use the version we are currently submitting feel free to look at the updated vignette [here](https://github.com/MarcElosua/SPOTlight/blob/main/vignettes/SPOTlight_kidney.Rmd). If you want to keep using the previous versions, you can still find it in the [spotlight-0.1.7 branch](https://github.com/MarcElosua/SPOTlight/tree/spotlight-0.1.7) and follow the previous [vignette](https://marcelosua.github.io/SPOTlight/).
`SPOTlight` provides a tool that enables the deconvolution of mixtures of cells from a single-cell reference. Originally developed for 10X's Visium - spatial transcriptomics- technology, it can be used for all technologies that output mixtures of cells. It is compatible with Bioconductor's `SingleCellExperiment` and `SpatialExperiment` classes. Furthermore, the package also provides visualization tools to assess the results of the deconvolution. Briefly, `SPOTlight` is based on finding topic profile signatures, by means of an NMFreg model, for each cell type and then optimizing the cell types proportions to fit the mixture we want to deconvolute.
## Installation
``` r
install.packages("BiocManager")
BiocManager::install("SPOTlight")
# Or the devel version
BiocManager::install("SPOTlight", version = "devel")
```
Alternatively, you can install it from GitHub using the [devtools](https://github.com/hadley/devtools) package.
``` r
install.packages("devtools")
library(devtools)
install_github("https://github.com/MarcElosua/SPOTlight")
```
### References
- Elosua-Bayes M, Nieto P, Mereu E, Gut I, Heyn H (2021): *SPOTlight: seeded NMF regression to deconvolute spatial transcriptomics spots with single-cell transcriptomes*. **Nucleic Acids Res** 49(9):e50.