Skip to content

Commit 573aa9a

Browse files
lambdamoseslambdamoses
committed
Core of that plotting function
1 parent 0b758bb commit 573aa9a

File tree

5 files changed

+253
-20
lines changed

5 files changed

+253
-20
lines changed

‎DESCRIPTION

+5
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,10 @@ Authors@R:
1212
Description: Adapts geospatial methods for spatial omics.
1313
Imports:
1414
BiocParallel,
15+
ggnewscale,
16+
ggplot2,
1517
S4Vectors,
18+
scico,
1619
sf,
1720
SingleCellExperiment,
1821
SpatialFeatureExperiment,
@@ -26,3 +29,5 @@ Encoding: UTF-8
2629
LazyData: true
2730
RoxygenNote: 7.1.2
2831
Config/testthat/edition: 3
32+
Depends:
33+
R (>= 2.10)

‎R/moran-geary.R

+1-6
Original file line numberDiff line numberDiff line change
@@ -118,12 +118,7 @@ setMethod("calculateGearysC", "ANY", function(x, listw, BPPARAM = SerialParam(),
118118
zero.policy = NULL, ...) {
119119
# Am I sure that I want to use logcounts as the default?
120120
sample_id <- .check_sample_id(x, sample_id)
121-
if (!all(features %in% rownames(x))) {
122-
features <- intersect(features, rownames(x))
123-
if (!length(features)) {
124-
stop("None of the specified genes/features are found in the SFE object.")
125-
}
126-
}
121+
features <- .check_features(x, features)[["assay"]]
127122
listw_use <- colGraph(x, type = colGraphName, sample_id = sample_id)
128123
mat <- assay(x, exprs_values)[features, colData(x)$sample_id %in% sample_id]
129124
fun(mat, listw_use, BPPARAM = BPPARAM, zero.policy = zero.policy, ...)

‎R/plot.R

+226-14
Original file line numberDiff line numberDiff line change
@@ -6,19 +6,6 @@
66
# 12. Cluster the correlograms and plot the clusters
77
# 13. Plot the graphs with spatial coordinates
88

9-
#' Plot gene expression in space
10-
#'
11-
#' Unlike \code{Seurat} and \code{ggspavis}, plotting functions in this package
12-
#' uses \code{geom_sf} whenever applicable.
13-
14-
plotSFExpression <- function(sfe, colGeometryName, sample_id, color_by,
15-
divergent = FALSE,
16-
diverge_center = 0, colour_by = color_by,
17-
size = 0) {
18-
19-
}
20-
21-
229
#' Get beginning and end of palette to center a divergent palette
2310
#'
2411
#' The title is self-explanatory.
@@ -28,7 +15,7 @@ plotSFExpression <- function(sfe, colGeometryName, sample_id, color_by,
2815
#' @return A numeric vector of length 2, the first element is for beginning, and
2916
#' the second for end. The values are between 0 and 1.
3017
#' @export
31-
get_diverge_range <- function(values, diverge_center = 0) {
18+
getDivergeRange <- function(values, diverge_center = 0) {
3219
rg <- range(values, na.rm = TRUE)
3320
if (!between(diverge_center, rg[1], rg[2])) {
3421
stop("diverge_center must be between the minimum and maximum of the metric.")
@@ -44,6 +31,231 @@ get_diverge_range <- function(values, diverge_center = 0) {
4431
c(pal_begin, pal_end)
4532
}
4633

34+
.get_applicable <- function(df, fill_by, color_by, shape_by, linetype_by,
35+
size_by, size, shape, linetype, alpha, color,
36+
fill) {
37+
if (st_is(df, "POINT") || st_is(df, "MULTIPOINT")) {
38+
aes_applicable <- list(geometry = "geometry",
39+
color = color_by, shape = shape_by,
40+
size = size_by)
41+
if (isTRUE(all.equal(0, size))) size <- 1
42+
fixed_applicable <- list(size = size, shape = shape, alpha = alpha,
43+
color = color)
44+
if (!is.null(shape) && shape > 20L) {
45+
if (!is.null(fill_by)) aes_applicable[["color"]] <- NULL
46+
aes_applicable <- c(aes_applicable, list(fill = fill_by))
47+
fixed_applicable <- c(fixed_applicable, list(fill = fill))
48+
}
49+
} else if (st_is(df, "LINESTRING") || st_is(df, "MULTILINESTRING")) {
50+
aes_applicable <- list(geometry = "geometry", linetype = linetype_by,
51+
color = color_by, shape = shape_by, size = size_by)
52+
if (isTRUE(all.equal(0, size))) size <- 1
53+
fixed_applicable <- list(size = size, linetype = linetype, alpha = alpha,
54+
color = color)
55+
} else {
56+
if (!is.null(fill_by)) color_by <- NULL
57+
aes_applicable <- list(geometry = "geometry", fill = fill_by,
58+
color = color_by, size = size_by,
59+
linetype = linetype_by)
60+
fixed_applicable <- list(size = size, linetype = linetype, alpha = alpha,
61+
color = color, fill = fill)
62+
}
63+
aes_applicable <- .drop_null_list(aes_applicable)
64+
fixed_applicable <- .drop_null_list(fixed_applicable)
65+
fixed_applicable <- fixed_applicable[setdiff(names(fixed_applicable),
66+
names(aes_applicable))]
67+
list(aes_applicable, fixed_applicable)
68+
}
69+
70+
.get_pal <- function(df, applicable, option, divergent, diverge_center) {
71+
cols_check_names <- unlist(applicable)
72+
cols_check_names <- cols_check_names[names(cols_check_names) %in% c("fill", "color")]
73+
if (length(cols_check_names)) {
74+
# color_by is set to NULL if fill_by is applicable and present
75+
m <- st_drop_geometry(df)[,cols_check_names]
76+
is_discrete <- function(m) is.character(m) | is.factor(m) | is.logical(m)
77+
.aes <- names(cols_check_names)
78+
} else {
79+
return(NULL)
80+
}
81+
if (is_discrete) {
82+
.pal <- switch (option, Voyager::ditto_colors, rev(Voyager::ditto_colors))
83+
pal_fun <- switch (.aes, fill = scale_fill_manual, color = scale_color_manual)
84+
pal <- pal_fun(values = .pal, na.value = "gray")
85+
} else {
86+
if (divergent) {
87+
if (!is.null(diverge_center)) {
88+
r <- df[[aes_applicable[["fill"]]]]
89+
pal_range <- getDivergeRange(r, diverge_center)
90+
pal_begin <- pal_range[1]
91+
pal_end <- pal_range[2]
92+
} else {
93+
pal_begin <- 0
94+
pal_end <- 1
95+
}
96+
.pal <- switch(option, "roma", "bam")
97+
pal_fun <- switch (.aes, fill = scale_fill_scico,
98+
color = scale_color_scico)
99+
pal <- pal_fun(palette = .pal, begin = pal_begin,
100+
end = pal_end, na.value = "gray")
101+
} else {
102+
pal_fun <- switch(.aes, fill = scale_fill_brewer,
103+
color = scale_color_brewer)
104+
.pal <- switch(option, "Blues", "PuRd")
105+
pal <- pal_fun(na.value = "gray", palette = .pal, direction = 1)
106+
}
107+
}
108+
pal
109+
}
110+
111+
.annot_defaults <- function(annot_params) {
112+
defaults <- list(fill_by = NULL, color_by = NULL, shape_by = NULL,
113+
linetype_by = NULL, size_by = NULL, size = 0, shape == 16,
114+
linetype = 1, alpha = 1, color = "black", fill = "gray70",
115+
divergent = FALSE, diverge_center = NULL)
116+
if (!is.null(annot_params$fill_by)) annot_params$color_by <- NULL
117+
fill <- defaults[setdiff(names(annot_params), names(defaults))]
118+
.drop_null_list(c(annot_params, fill))
119+
}
120+
121+
#' @importFrom sf st_is st_drop_geometry
122+
#' @importFrom ggplot2 ggplot aes_string geom_sf scale_fill_manual
123+
#' scale_color_manual scale_fill_brewer scale_color_brewer
124+
#' @importFrom scico scale_fill_scico scale_color_scico
125+
#' @importFrom ggnewscale new_scale_color
126+
.plot_var_sf <- function(df, fill_by, color_by, shape_by, linetype_by, size_by,
127+
annot_df, annot_params, divergent, diverge_center,
128+
only_plot_expressed, size, shape, linetype, alpha,
129+
color, fill) {
130+
# Add annotGeometry if present
131+
if (!is.null(annot_df)) {
132+
annot_params <- .annot_defaults(annot_params)
133+
.by <- grepl("_by$", names(annot_aes))
134+
annot_fixed <- annot_params[!.by]
135+
annot_aes <- annot_params[.by]
136+
aes_annot <- do.call(aes_string, annot_aes)
137+
geom_annot <- do.call(geom_sf, c(list(mapping = aes_use, data = annot_df),
138+
annot_fixed))
139+
pal_annot <- .get_pal(annot_df, annot_aes, 2, annot_params$divergent,
140+
annot_params$diverge_center)
141+
}
142+
143+
p <- ggplot()
144+
# Polygon annotations go beneath feature plot
145+
is_annot_polygon <- !is.null(annot_df) && (st_is(annot_df, "POLYGON") || st_is(annot_df, "MULTIPOLYGON"))
146+
if (is_annot_polygon) {
147+
p <- p + geom_annot
148+
if (!is.null(pal_annot)) p <- p + pal_annot
149+
}
150+
151+
applicable <- .get_applicable(df, fill_by, color_by, shape_by, linetype_by,
152+
size_by, size, shape, linetype, alpha, color,
153+
fill)
154+
if (only_plot_expressed) {
155+
col_filter <- unlist(applicable[[1]][names(applicable[[1]]) %in% c("fill", "color")])
156+
if (all(df[[col_filter]] >= 0)) {
157+
df <- df[df[[col_filter]] > 0,]
158+
}
159+
}
160+
161+
if ("fill" %in% names(applicable[[1]]) && is_annot_polygon)
162+
p <- p + new_scale_fill()
163+
aes_use <- do.call(aes_string, applicable[[1]])
164+
geom_use <- do.call(geom_sf, c(list(mapping = aes_use, data = df),
165+
applicable[[2]]))
166+
p <- p + geom_use
167+
168+
# Palette
169+
pal <- .get_pal(df, applicable[[1]], 1, divergent, diverge_center)
170+
if (!is.null(pal)) p <- p + pal
171+
172+
# Line and point annotations go above feature plot
173+
if (!is.null(annot_df) && !is_annot_polygon) {
174+
if (!is.null(pal_annot) && "color" %in% names(applicable[[1]])) {
175+
p <- p + new_scale_color()
176+
}
177+
p <- p + geom_use
178+
if (!is.null(pal_annot)) {
179+
p <- p + pal_annot
180+
}
181+
}
182+
p
183+
}
184+
185+
#' Plot gene expression in space
186+
#'
187+
#' Unlike \code{Seurat} and \code{ggspavis}, plotting functions in this package
188+
#' uses \code{geom_sf} whenever applicable.
189+
#'
190+
#' In the documentation of this function, a "feature" can be a gene (or whatever
191+
#' entity that corresponds to rows of the gene count matrix), a column in
192+
#' \code{colData}, or a column in the \code{colGeometry} \code{sf} data frame
193+
#' specified in the \code{colGeometryName} argument.
194+
#'
195+
#' For continuous variables, the Blues palette from colorbrewer is used if
196+
#' \code{divergent = FALSE}, and the roma palette from the \code{scico} package
197+
#' if \code{divergent = TRUE}. For discrete variables, the \code{dittoSeq}
198+
#' palette is used. The defaults are colorblind friendly. For annotation, the
199+
#' PuRd colorbrewer palette is used for continuous variables and the other end
200+
#' of the \code{dittoSeq} palette is used for discrete variables.
201+
#'
202+
#' @inheritParams calculateMoransI
203+
#' @param sfe A \code{SpatialFeatureExperiment} object.
204+
#' @param fill_by Feature to fill the polygons or point shapes that supports
205+
#' fill. The polygons will not be filled if \code{NULL}.
206+
#' @param color_by Feature to color the points or lines, including outlines of
207+
#' polygons. For polygons, this is ignored if \code{fill_by} is specified to
208+
#' avoid an overly garish and hard to read plot.
209+
#' @param shape_by Feature for shape of points, only applicable if the
210+
#' \code{colGeometry} from \code{colGeometryName} is of type POINT or
211+
#' MULTIPOINT.
212+
#' @param linetype_by Feature for line type, only applicable for LINESTRING,
213+
#' MULTILINESTRING, POLYGON, and MULTIPOLYGON.
214+
#' @param divergent Logical, whether a divergent palette should be used.
215+
#' @param diverge_center If \code{divergent = TRUE}, the center from which the
216+
#' palette should diverge. If \code{NULL}, then not centering.
217+
#' @param only_plot_expressed Logical, if \code{TRUE}, and if all values are
218+
#' non-negative, then geometries with value 0 are not plotted.
219+
#' @param colour_by Same as color_by.
220+
#' @param size Fixed size of points or width of lines, including outlines of
221+
#' polygons. For polygons, this defaults to 0, meaning no outlines. For points
222+
#' and lines, this defaults to 1. Ignored if \code{size_by} is specified.
223+
#' @param shape Fixed shape of points, ignored if \code{shape_by} is specified
224+
#' and applicable.
225+
#' @param linetype Fixed line type, ignored if \code{linetype_by} is specified
226+
#' and applicable.
227+
#' @param color Fixed color for \code{colGeometry} if \code{color_by} is not
228+
#' specified or not applicable, or for \code{annotGeometry} if \code{annot_color_by}
229+
#' is not specified or not applicable.
230+
#' @param fill Similar to \code{color}, but for fill.
231+
#' @param alpha Transparency.
232+
#' @param annotGeometryName Name of a \code{annotGeometry} of the SFE object, to
233+
#' annotate the gene expression plot.
234+
#' @param annot_color_by Same as \code{color_by}, but for the annotation when
235+
#' \code{annotGeometryName} is specified.
236+
#' @param annot_colour_by Same as \code{annot_color_by}.
237+
plotSpatialFeature <- function(sfe, colGeometryName, features, sample_id,
238+
fill_by = NULL, color_by = NULL, shape_by = NULL,
239+
linetype_by = NULL, size_by = NULL,
240+
annotGeometryName = NULL, annot_aes = list(),
241+
exprs_values = "logcounts", divergent = FALSE,
242+
diverge_center = NULL, only_plot_expressed = FALSE,
243+
colour_by = color_by, size = 0,
244+
shape = 16, linetype = 1, alpha = 1, color = "black",
245+
fill = "gray70") {
246+
features_list <- .check_features(sfe, features, colGeometryName)
247+
features_use <- assay(sfe, exprs_values)[features, colData(sfe)$sample_id %in% sample_id]
248+
249+
df <- colGeometry(sfe, colGeometryName, sample_id = sample_id)
250+
if (length(features) == 1L) {
251+
df[[features]] <- features_use
252+
} else {
253+
features_use <- t(as.matrix(features_use))
254+
features_use <- as.data.frame(features_use)
255+
df <- cbind(df, features_use)
256+
}
257+
}
258+
47259
#' Use ggplot to plot the moran.plot results
48260
#'
49261
#' Also plots contours showing point density to deal with over-plotting.

‎R/utils.R

+21
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
.check_features_all <- function(x, features, colGeometryName) {
2+
# Check if features are in the gene count matrix or colData.
3+
# If not found, then assume that they're in the colGeometry
4+
features_assay <- intersect(features, rownames(x))
5+
features_coldata <- intersect(features, names(colData(x)))
6+
if (missing(colGeometryName)) {
7+
features_colgeom <- NULL
8+
} else {
9+
cg <- colGeometry(x, type = colGeometryName)
10+
features_colgeom <- intersect(features, names(st_drop_geometry(cg)))
11+
}
12+
out <- list(assay = featuers_assay,
13+
coldata = features_coldata,
14+
colgeom = features_colgeom)
15+
if (all(lengths(out) == 0L)) {
16+
stop("None of the features are found in the SFE object.")
17+
}
18+
return(out)
19+
}
20+
21+
.drop_null_list <- function(l) as.list(unlist(l, use.names = TRUE))

‎data/ditto_colors.rda

279 Bytes
Binary file not shown.

0 commit comments

Comments
 (0)