04-feature-selection.Rmd

```{r, parameters-and-defaults, include = FALSE}
module <- "scRNAseq"
section <- "feature_selection"
parameters_and_defaults <- list(
  assay = structure(
    "logcounts",
    type = "character",
    choices = c("logcounts", "logtpm", "norm_sumfactor", "norm_TMM"),
    several.ok = FALSE
  ),
  celltype = structure(
    "none",
    type = "character",
    choices = NA,
    several.ok = FALSE
  ),
  include_methods = structure(
    c(),
    type = "character",
    choices = c("cv2", "dropout", "fano", "gini"),
    several.ok = TRUE
  ),
  cutoff = structure(
    stats::qnorm(0.975),
    type = "numeric",
    choices = NA,
    several.ok = FALSE
  ),
  wgcna_cor_method = structure(
    "spearman",
    type = "character",
    choices = c("pearson", "spearman", "kendall"),
    several.ok = FALSE
  )
)
```

```{r parameter-merge, include = FALSE}
local_params <- module %>%
  options() %>%
  magrittr::extract2(module) %>%
  magrittr::extract2(section) %>%
  ReporteR.base::validate_params(parameters_and_defaults)
```

```{r scRNAseq-feature-selection-load, include=FALSE, eval = !exists("object_filtered")}
assertive.files::is_existing_file(managed_objects$paths$object_filtered$path)

object_filtered <- readRDS(managed_objects$paths$object_filtered$path) %>%
  ReporteR.base::flag_persistent()
```

```{r scRNAseq-feature-selection-checks, include = FALSE, echo = FALSE}
assertive.sets::assert_is_subset(local_params$assay, SummarizedExperiment::assayNames(object_filtered))
```

```{r scRNAseq-feature-selection-vars, include = FALSE, echo = FALSE}
celltypes <- list()
if (local_params$celltype != "none") {
  assertive.sets::assert_is_subset(local_params$celltype, colnames(SummarizedExperiment::colData(object_filtered)))
  
  SummarizedExperiment::colData(object_filtered)[, local_params$celltype] <- droplevels(factor(SummarizedExperiment::colData(object_filtered)[, local_params$celltype]))
  celltypes <- sapply(levels(SummarizedExperiment::colData(object_filtered)[, local_params$celltype]), function(t) {
    which(SummarizedExperiment::colData(object_filtered)[, local_params$celltype] == t)
  })
}
celltypes$all <- 1:ncol(object_filtered)

#
# Calculate important statistics
#
means <- lapply(celltypes, function(x) {
  subset <- object_filtered[, x]
  data <- (2^SummarizedExperiment::assay(subset, local_params$assay))-1

  log(Matrix::rowMeans(data) + 1)/log(10)
})

cvs <- lapply(celltypes, function(x) {
  subset <- object_filtered[, x]
  data <- (2^SummarizedExperiment::assay(subset, local_params$assay))-1

  log10(apply(data, 1, singlecellutils::cv2.fun))
})

dropouts <- lapply(celltypes, function(x) {
  subset <- object_filtered[, x]
  data <- (2^SummarizedExperiment::assay(subset, local_params$assay))-1

  apply(data, 1, singlecellutils::dropout.fun)
})

fanos <- lapply(celltypes, function(x) {
  subset <- object_filtered[, x]
  data <- (2^SummarizedExperiment::assay(subset, local_params$assay))-1

  apply(data, 1, singlecellutils::fano.fun)
})

#
# Plot themes
#
theme_feature_selection_scatter <- ggplot2::theme(plot.background = ggplot2::element_blank(),
                                              panel.grid.major = ggplot2::element_line(size=.2, colour = "grey"),
                                              panel.grid.minor = ggplot2::element_line(size=.1, colour = "grey"),
                                              panel.border = ggplot2::element_blank(),
                                              panel.background = ggplot2::element_blank(),
                                              axis.line.x = ggplot2::element_line(size=.3),
                                              axis.line.y = ggplot2::element_line(size=.3),
                                              axis.text = ggplot2::element_text(size = 4),
                                              axis.title.x = ggplot2::element_text(size = 5, margin = ggplot2::margin(-2, 0, 0, 0)),
                                              axis.title.y = ggplot2::element_text(size = 5, margin = ggplot2::margin(0, -2, 0, 0)),
                                              plot.title = ggplot2::element_text(face="bold", color="black", size=5),
                                              legend.text = ggplot2::element_text(size=5),
                                              legend.title = ggplot2::element_text(size = 5),
                                              legend.key.size = grid::unit(2, "mm"),
                                              legend.margin = ggplot2::margin(b = 2),
                                              legend.position = c(0,1),
                                              legend.justification = c(0,0),
                                              legend.background = ggplot2::element_rect(fill = "white"),
                                              legend.direction = "horizontal")

```

## Feature selection

```{r scRNAseq-feature-selection-A-cv2, echo=FALSE, include=FALSE, R.options=params}
rmd_path <- system.file(file.path('content', '04-feature-selection-A-cv2.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path = ReporteR.base::make_md_path(rmd_path)
knitr::knit_child(rmd_path, output = md_path)
```

```{r scRNAseq-feature-selection-A-cv2-include, echo = FALSE, eval = ifelse(exists('local_params'), 'cv2' %in% local_params$include_methods, FALSE), results="asis"}
rmd_path <- system.file(file.path('content', '04-feature-selection-A-cv2.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path <- ReporteR.base::make_md_path(rmd_path)

assertive.files::assert_all_are_readable_files(md_path)
md_path %>%
  readLines() %>%
  cat(sep = '\n')
```

```{r scRNAseq-feature-selection-B-dropout, echo=FALSE, include=FALSE, R.options=params}
rmd_path <- system.file(file.path('content', '04-feature-selection-B-dropout.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path = ReporteR.base::make_md_path(rmd_path)
knitr::knit_child(rmd_path, output = md_path)
```

```{r scRNAseq-feature-selection-B-dropout-include, echo = FALSE, eval = ifelse(exists('local_params'), 'dropout' %in% local_params$include_methods, FALSE), results="asis"}
rmd_path <- system.file(file.path('content', '04-feature-selection-B-dropout.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path <- ReporteR.base::make_md_path(rmd_path)

assertive.files::assert_all_are_readable_files(md_path)
md_path %>%
  readLines() %>%
  cat(sep = '\n')
```

```{r scRNAseq-feature-selection-C-fano, echo=FALSE, include=FALSE, R.options=params}
rmd_path <- system.file(file.path('content', '04-feature-selection-C-fano.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path = ReporteR.base::make_md_path(rmd_path)
knitr::knit_child(rmd_path, output = md_path)
```

```{r scRNAseq-feature-selection-C-fano-include, echo = FALSE, eval = ifelse(exists('local_params'), 'fano' %in% local_params$include_methods, FALSE), results="asis"}
rmd_path <- system.file(file.path('content', '04-feature-selection-C-fano.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE)
md_path <- ReporteR.base::make_md_path(rmd_path)

assertive.files::assert_all_are_readable_files(md_path)
md_path %>%
  readLines() %>%
  cat(sep = '\n')
```

```{r scRNAseq-feature-selection-select-features, echo = FALSE, eval = ifelse(exists('local_params'), length(local_params$include_methods) > 0, FALSE), R.options=params}
columns <- unlist(lapply(local_params$include_methods, function(m) {
  if(length(setdiff(names(celltypes), "all")) > 0) {
    paste0(".heterogeneity_", c(m, paste0(m, "_", setdiff(names(celltypes), "all"))))
  } else {
    paste0(".heterogeneity_", m)
  }
}))

dat <- as.matrix(SummarizedExperiment::rowData(object_filtered)[, make.names(columns)])
SummarizedExperiment::rowData(object_filtered)$is_het <- rowSums(dat > local_params$cutoff) > 0
```

```{r scRNAseq-feature-selection-Z-distance, echo = FALSE, child = system.file(file.path('content', '04-feature-selection-Z-distance.Rmd'), package = 'ReporteR.scRNAseq', mustWork = TRUE), R.options = params, eval = ifelse(exists('local_params'), local_params$celltype != "none", FALSE)}
```

```{r scRNAseq-feature-selection-terminal-cleanup, include = FALSE}
saveRDS(object = object_filtered, file = managed_objects$paths$object_filtered$path)

ReporteR.base::purge_nonpersistent()
```