Merge pull request #121 from BodenmillerGroup/plotSpatial_aes_fix

Plot spatial aes fix

.github/workflows/build-checks-devel.yml

@@ -10,7 +10,7 @@ on:
 jobs:
  R-CMD-check:
  runs-on: ubuntu-latest
- container: rocker/r-ver:4.3
+ container: rocker/r-ver:devel
 
  steps:
  - uses: actions/checkout@v2

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: imcRtools
-Version: 1.9.0
+Version: 1.9.1
 Title: Methods for imaging mass cytometry data analysis
 Description: 
  This R package supports the handling and analysis of imaging mass cytometry 
@@ -56,10 +56,13 @@ Imports:
  concaveman,
  tidyselect,
  distances,
- MatrixGenerics
+ MatrixGenerics,
+ rlang,
+ grDevices
 Suggests:
  CATALYST,
  grid,
+ tidyr,
  BiocStyle,
  knitr,
  rmarkdown,

NAMESPACE

@@ -86,7 +86,7 @@ importFrom(dplyr,select)
 importFrom(dplyr,summarise)
 importFrom(dplyr,summarize)
 importFrom(dplyr,sym)
-importFrom(ggplot2,aes_)
+importFrom(ggplot2,aes)
 importFrom(ggplot2,coord_fixed)
 importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_text)
@@ -124,6 +124,7 @@ importFrom(methods,is)
 importFrom(pheatmap,pheatmap)
 importFrom(readr,cols)
 importFrom(readr,read_delim)
+importFrom(rlang,.data)
 importFrom(scuttle,aggregateAcrossCells)
 importFrom(sf,st_area)
 importFrom(sf,st_buffer)

NEWS

@@ -213,3 +213,9 @@ Changes in version 1.7.8 (2023-10-19)
 
 + spatialCoords are not initialised with rownames anymore
 
+Changes in version 1.9.1 (2023-11-20)
+
++ Switched from aes_ to .data
++ Initialise SPE and SCE objects with colnames
++ Additional test within binAcrossPixels
+

R/binAcrossPixels.R

@@ -54,8 +54,12 @@ binAcrossPixels <- function(object,
  stop("'statistic' must be 'sum', 'mean' or 'median'.")
  }
 
- cur_split <- split(object[[spot_id]], f = object[[spot_id]])
- cur_split <- lapply(cur_split, function(x){ceiling(seq_along(x)/bin_size)})
+ cur_split_tmp <- split(object[[spot_id]], f = object[[spot_id]])
+ cur_split <- lapply(cur_split_tmp, function(x){ceiling(seq_along(x)/bin_size)})
+
+ if (!isTRUE(all.equal(as.vector(unlist(cur_split_tmp)), object[[spot_id]]))) {
+ stop("Spot IDs of pixels within 'object' are not ordered alphabetically.")
+ }
 
  cur_df <- DataFrame(spot_id = object[[spot_id]],
  bin = unlist(cur_split))

R/plotSpatial.R

@@ -133,8 +133,9 @@
 #' 
 #' @import ggraph
 #' @importFrom tidygraph tbl_graph 
-#' @importFrom ggplot2 aes_ theme element_text element_blank scale_color_manual
-#' scale_size_manual scale_shape_manual
+#' @importFrom ggplot2 theme element_text element_blank scale_color_manual
+#' scale_size_manual scale_shape_manual aes
+#' @importFrom rlang .data
 #' @export
 plotSpatial <- function(object,
  img_id,

R/read_cpout.R

@@ -171,5 +171,8 @@ read_cpout <- function(path,
 
  object <- .add_panel(object, path, panel_file, extract_metal_from)
 
+ # Add colnames
+ colnames(object) <- paste0(object$sample_id, "_", object$ObjectNumber)
+
  return(object)
 }

R/read_steinbock.R

@@ -161,5 +161,8 @@ read_steinbock <- function(path,
  # Add panel data
  object <- .add_panel(object, path, panel_file, extract_names_from)
 
+ # Add colnames
+ colnames(object) <- paste0(object$sample_id, "_", object$ObjectNumber)
+
  return(object)
 }

R/utils.R

@@ -416,73 +416,61 @@
  node_color_fix, node_size_fix, node_shape_fix,
  edge_color_by, edge_width_by, edge_color_fix,
  edge_width_fix, nodes_first){
-
- node_color_by <- if(is.null(node_color_by)) NULL else as.name(node_color_by)
- node_size_by <- if(is.null(node_size_by)) NULL else as.name(node_size_by)
- node_shape_by <- if(is.null(node_shape_by)) NULL else as.name(node_shape_by)
- edge_color_by <- if(is.null(edge_color_by)) NULL else as.name(edge_color_by)
- edge_width_by <- if(is.null(edge_width_by)) NULL else as.name(edge_width_by)
-
- if (!is.null(node_color_fix)){ node_color_by <- as.character(node_color_fix)
- } else { node_color_by <- node_color_by }
- if (!is.null(node_size_fix)){ node_size_by <- as.character(node_size_fix)
- } else { node_size_by <- node_size_by }
- if (!is.null(node_shape_fix)){ node_shape_by <- as.character(node_shape_fix)
- } else { node_shape_by <- node_shape_by }
- if (!is.null(edge_color_fix)){ edge_color_by <- as.character(edge_color_fix)
- } else { edge_color_by <- edge_color_by }
- if (!is.null(edge_width_fix)){edge_width_by <- as.character(edge_width_fix)
- } else { edge_width_by <- edge_width_by}
+
+ node_mapping <- aes(colour = .data[[node_color_by]],
+ size = .data[[node_size_by]],
+ shape = .data[[node_shape_by]])
+ if (is.null(node_color_by)) {node_mapping$colour <- NULL}
+ if (is.null(node_size_by)) {node_mapping$size <- NULL}
+ if (is.null(node_shape_by)) {node_mapping$shape <- NULL}
+ if (!is.null(node_color_fix)) {node_mapping$colour <- as.character(node_color_fix)}
+ if (!is.null(node_size_fix)) {node_mapping$size <- as.character(node_size_fix)}
+ if (!is.null(node_shape_fix)) {node_mapping$shape <- as.character(node_shape_fix)}
 
  if (draw_edges) {
+
+ edge_mapping <- aes(edge_colour = .data[[edge_color_by]],
+ edge_width = .data[[edge_width_by]])
+ if (is.null(edge_color_by)) {edge_mapping$edge_colour <- NULL}
+ if (is.null(edge_width_by)) {edge_mapping$edge_width <- NULL}
+ if (!is.null(edge_color_fix)) {edge_mapping$edge_colour <- as.character(edge_color_fix)}
+ if (!is.null(edge_width_fix)) {edge_mapping$edge_width <- as.character(edge_width_fix)}
+
  if (!is.null(arrow)) {
 
  if (is.null(end_cap)) {
  end_cap <- circle(0.1, 'cm')
  }
 
  if (directed) {
- cur_geom_edge <- geom_edge_fan(aes_(edge_colour = edge_color_by,
- edge_width = edge_width_by),
+ cur_geom_edge <- geom_edge_fan(edge_mapping,
  end_cap = end_cap,
  arrow = arrow)
  } else {
- cur_geom_edge <- geom_edge_link(aes_(
- edge_colour = edge_color_by,
- edge_width = edge_width_by),
+ cur_geom_edge <- geom_edge_link(edge_mapping,
  end_cap = end_cap,
  arrow = arrow)
  }
  } else {
  if (directed) {
- cur_geom_edge <- geom_edge_fan0(aes_(
- edge_colour = edge_color_by,
- edge_width = edge_width_by))
+ cur_geom_edge <- geom_edge_fan0(edge_mapping)
  } else {
- cur_geom_edge <- geom_edge_link0(aes_(
- edge_colour = edge_color_by,
- edge_width = edge_width_by))
+ cur_geom_edge <- geom_edge_link0(edge_mapping)
  }
  }
 
  if (nodes_first) {
  p <- ggraph(layout) +
- geom_node_point(aes_(colour = node_color_by,
- size = node_size_by,
- shape = node_shape_by)) +
+ geom_node_point(node_mapping) +
  cur_geom_edge
  } else {
  p <- ggraph(layout) +
  cur_geom_edge +
- geom_node_point(aes_(colour = node_color_by,
- size = node_size_by,
- shape = node_shape_by))
+ geom_node_point(node_mapping)
  }
  } else {
  p <- ggraph(layout) +
- geom_node_point(aes_(colour = node_color_by,
- size = node_size_by,
- shape = node_shape_by))
+ geom_node_point(node_mapping)
  }
 
  return(p)
@@ -1018,7 +1006,7 @@
  return(edges)
 }
 
-#' @importFrom ggplot2 aes_ guide_legend guide_colorbar guides scale_size_manual
+#' @importFrom ggplot2 guide_legend guide_colorbar guides scale_size_manual
 #' @importFrom ggraph geom_edge_link geom_node_label geom_node_point ggraph
 #' @importFrom igraph layout.sugiyama vertex_attr
 
@@ -1063,9 +1051,9 @@
  }
 
  if (!is.null(node_color_by)) {
- cur_geom_node <- geom_node_point(aes_(color = color, size = size))
+ cur_geom_node <- geom_node_point(aes(color = color, size = size))
  } else {
- cur_geom_node <- geom_node_point(aes_(size = size), color = color)
+ cur_geom_node <- geom_node_point(aes(size = size), color = color)
  }
 
  ## node geom label
@@ -1077,16 +1065,16 @@
 
  if(node_label_repel){
  if (!is.null(node_label_color_by)) {
- cur_geom_node_label <- geom_node_label(aes_(color = color_label, 
+ cur_geom_node_label <- geom_node_label(aes(color = color_label, 
  label = vertex_attr(graph, "name")), 
  repel = TRUE, show.legend = FALSE)
  } else {
- cur_geom_node_label <- geom_node_label(aes_(label = vertex_attr(graph, "name")), 
+ cur_geom_node_label <- geom_node_label(aes(label = vertex_attr(graph, "name")), 
  color = color_label, 
  repel = TRUE, show.legend = FALSE)
  }
  } else {
- cur_geom_node_label = NULL
+ cur_geom_node_label <- NULL
  } 
 
  # specify vertical layout with sugiyama

tests/testthat/test_binAcrossPixels.R

@@ -24,6 +24,30 @@ test_that("binAcrossPixels function works.", {
  expect_equal(counts(out)[,out$sample_id == "Dy164"][,1], rowSums(counts(cur_sce)[,cur_sce$sample_id == "Dy164"][,1:10]))
  expect_equal(counts(out)[,out$sample_id == "Dy164"][,2], rowSums(counts(cur_sce)[,cur_sce$sample_id == "Dy164"][,11:20]))
 
+ test <- aggregate(t(counts(cur_sce)), by = list(cur_sce$sample_id, rep(rep(1:10, each = 10), 4)), FUN = "sum")
+ test <- test[order(test$Group.1, test$Group.2),]
+
+ test2 <- counts(out)
+ test <- t(as.matrix(test[,-c(1,2)]))
+
+ dimnames(test2) <- NULL
+ dimnames(test) <- NULL
+
+ expect_equal(test2, test)
+
+ expect_silent(out <- binAcrossPixels(cur_sce, bin_size = 10, statistic = "mean"))
+
+ test <- aggregate(t(counts(cur_sce)), by = list(cur_sce$sample_id, rep(rep(1:10, each = 10), 4)), FUN = "mean")
+ test <- test[order(test$Group.1, test$Group.2),]
+
+ test2 <- counts(out)
+ test <- t(as.matrix(test[,-c(1,2)]))
+
+ dimnames(test2) <- NULL
+ dimnames(test) <- NULL
+
+ expect_equal(test2, test)
+
  # Works
  expect_silent(out <- binAcrossPixels(cur_sce, bin_size = 2))
  expect_s4_class(out, "SingleCellExperiment")
@@ -61,6 +85,26 @@ test_that("binAcrossPixels function works.", {
  expect_equal(counts(out)[,out$sample_id == "Dy164"][,1], rowMeans(counts(cur_sce)[,cur_sce$sample_id == "Dy164"][,1:5]))
  expect_equal(counts(out)[,out$sample_id == "Dy164"][,2], rowMeans(counts(cur_sce)[,cur_sce$sample_id == "Dy164"][,6:10]))
 
+ # Works
+ expect_silent(out <- binAcrossPixels(cur_sce, bin_size = 3))
+ expect_s4_class(out, "SingleCellExperiment")
+
+ # colData are correct
+ expect_equal(out$sample_id, rep(c("Dy161", "Dy162", "Dy163", "Dy164"), each = 34))
+ expect_equal(out$spot_id, rep(c("Dy161", "Dy162", "Dy163", "Dy164"), each = 34))
+ expect_equal(as.numeric(out$bin), rep(1:34, 4))
+ expect_equal(as.numeric(out$ncells), rep(c(rep(3, 33), 1), 4))
+
+ # rowData are correct
+ expect_equal(rowData(cur_sce), rowData(out))
+
+ # Summarized counts are correct
+ expect_equal(counts(out)[,1], rowSums(counts(cur_sce)[,1:3]))
+ expect_equal(counts(out)[,2], rowSums(counts(cur_sce)[,4:6]))
+ expect_equal(counts(out)[,3], rowSums(counts(cur_sce)[,7:9]))
+ expect_equal(counts(out)[,4], rowSums(counts(cur_sce)[,10:12]))
+ expect_equal(counts(out)[,34], counts(cur_sce)[,100]) 
+
  # Error
  expect_error(binAcrossPixels("test"),
  regexp = "'object' needs to be a SingleCellExperiment object.",
@@ -80,4 +124,10 @@ test_that("binAcrossPixels function works.", {
  expect_error(binAcrossPixels(cur_sce, bin_size = 10, statistic = "test"),
  regexp = "'statistic' must be 'sum', 'mean' or 'median'.",
  fixed = TRUE)
+
+ cur_sce <- cur_sce[,sample(ncol(cur_sce))]
+
+ expect_error(binAcrossPixels(cur_sce, bin_size = 10),
+ regexp = "Spot IDs of pixels within 'object' are not ordered alphabetically.",
+ fixed = TRUE)
 })

tests/testthat/test_findBorderCells.R

@@ -175,6 +175,6 @@ test_that("findBorderCells function works if cells are not ordered by image", {
  expect_silent(sce2 <- findBorderCells(sce2, img_id = "ImageNb", border_dist = 10))
  plotSpatial(sce2, img_id = "ImageNb", node_color_by = "border_cells")
 
- all.equal(pancreasSCE$border_cells, sce2[,colnames(pancreasSCE)]$border_cells)
+ expect_equal(pancreasSCE$border_cells, sce2[,colnames(pancreasSCE)]$border_cells)
 
  })