R/utils.R
In enblacar/SCpubr: Generate Publication Ready Visualizations of Single Cell Transcriptomics Data
Defines functions
round_percent
range_norm
one_one_norm
zero_one_norm
compute_continuous_palette
check_Assay5
check_group_by
get_SCpubr_colors
handle_axis
guide_axis_label_trans
compute_umap_layer
get_axis_parameters
prepare_ggplot_alluvial_plot
check_parameters
get_data_column_in_context
get_data_column
modify_continuous_legend
compute_enrichment_scores
modify_string
add_scale
check_length
compute_factor_levels
check_and_set_slot
check_type
check_and_set_assay
check_and_set_dimensions
check_and_set_reduction
check_identity
remove_duplicated_features
remove_not_found_features
check_feature
check_limits
compute_scales
check_cutoffs
compute_scale_limits
generate_color_scale
check_consistency_colors_and_names
check_colors
check_Seurat
package_report
check_suggests
return_dependencies
crayon_key
add_tick
add_warning
add_cross
add_info
add_star
crayon_body
`%!in%`
named_list
named_vector
doc_function
Documented in
doc_function
named_list
named_vector
package_report
#' Mock function used to document all main function.
#'
#' @param sample \strong{\code{\link[SeuratObject]{Seurat}}} | A Seurat object, generated by \link[Seurat]{CreateSeuratObject}.
#' @param font.size \strong{\code{\link[base]{numeric}}} | Overall font size of the plot. All plot elements will have a size relationship with this font size.
#' @param font.type \strong{\code{\link[base]{character}}} | Base font family for the plot. One of:
#' \itemize{
#' \item \emph{\code{mono}}: Mono spaced font.
#' \item \emph{\code{serif}}: Serif font family.
#' \item \emph{\code{sans}}: Default font family.
#' }
#' @param legend.type \strong{\code{\link[base]{character}}} | Type of legend to display. One of:
#' \itemize{
#' \item \emph{\code{normal}}: Default legend displayed by \pkg{ggplot2}.
#' \item \emph{\code{colorbar}}: Redefined colorbar legend, using \link[ggplot2]{guide_colorbar}.
#' }
#' @param legend.position \strong{\code{\link[base]{character}}} | Position of the legend in the plot. One of:
#' \itemize{
#' \item \emph{\code{top}}: Top of the figure.
#' \item \emph{\code{bottom}}: Bottom of the figure.
#' \item \emph{\code{left}}: Left of the figure.
#' \item \emph{\code{right}}: Right of the figure.
#' \item \emph{\code{none}}: No legend is displayed.
#' }
#' @param legend.title \strong{\code{\link[base]{character}}} | Title for the legend.
#' @param legend.title.position \strong{\code{\link[base]{character}}} | Position for the title of the legend. One of:
#' \itemize{
#' \item \emph{\code{top}}: Top of the legend.
#' \item \emph{\code{bottom}}: Bottom of the legend.
#' \item \emph{\code{left}}: Left of the legend.
#' \item \emph{\code{right}}: Right of the legend.
#' }
#' @param legend.framewidth,legend.tickwidth \strong{\code{\link[base]{numeric}}} | Width of the lines of the box in the legend.
#' @param legend.framecolor \strong{\code{\link[base]{character}}} | Color of the lines of the box in the legend.
#' @param legend.tickcolor \strong{\code{\link[base]{character}}} | Color of the ticks of the box in the legend.
#' @param legend.length,legend.width \strong{\code{\link[base]{numeric}}} | Length and width of the legend. Will adjust automatically depending on legend side.
#' @param legend.icon.size \strong{\code{\link[base]{numeric}}} | Size of the icons in legend.
#' @param legend.ncol \strong{\code{\link[base]{numeric}}} | Number of columns in the legend.
#' @param legend.nrow \strong{\code{\link[base]{numeric}}} | Number of rows in the legend.
#' @param legend.byrow \strong{\code{\link[base]{logical}}} | Whether the legend is filled by row or not.
#' @param plot.title,plot.subtitle,plot.caption \strong{\code{\link[base]{character}}} | Title, subtitle or caption to use in the plot.
#' @param individual.titles,individual.subtitles,individual.captions \strong{\code{\link[base]{character}}} | Vector. Title, subtitle or caption to use in the plot when multiple features are passed on. Use NA to keep the original title.
#' @param reduction \strong{\code{\link[base]{character}}} | Reduction to use. Can be the canonical ones such as "umap", "pca", or any custom ones, such as "diffusion". If you are unsure about which reductions you have, use `Seurat::Reductions(sample)`. Defaults to "umap" if present or to the last computed reduction if the argument is not provided.
#' @param assay \strong{\code{\link[base]{character}}} | Assay to use. Defaults to the current assay.
#' @param slot \strong{\code{\link[base]{character}}} | Data slot to use. Only one of: counts, data, scale.data. Defaults to "data".
#' @param viridis.palette \strong{\code{\link[base]{character}}} | A capital letter from A to H or the scale name as in \link[viridis]{scale_fill_viridis}.
#' @param viridis.palette.pvalue,viridis.palette.logfc,viridis.palette.expression \strong{\code{\link[base]{character}}} | Viridis color palettes for the p-value, logfc and expression heatmaps. A capital letter from A to H or the scale name as in \link[viridis]{scale_fill_viridis}.
#' @param raster \strong{\code{\link[base]{logical}}} | Whether to raster the resulting plot. This is recommendable if plotting a lot of cells.
#' @param raster.dpi \strong{\code{\link[base]{numeric}}} | Pixel resolution for rasterized plots. Defaults to 1024. Only activates on Seurat versions higher or equal than 4.1.0.
#' @param plot_cell_borders \strong{\code{\link[base]{logical}}} | Whether to plot border around cells.
#' @param border.size \strong{\code{\link[base]{numeric}}} | Width of the border of the cells.
#' @param border.color \strong{\code{\link[base]{character}}} | Color for the border of the heatmap body.
#' @param na.value \strong{\code{\link[base]{character}}} | Color value for NA.
#' @param axis.text.x.angle \strong{\code{\link[base]{numeric}}} | Degree to rotate the X labels. One of: 0, 45, 90.
#' @param xlab,ylab \strong{\code{\link[base]{character}}} | Titles for the X and Y axis.
#' @param pt.size \strong{\code{\link[base]{numeric}}} | Size of the dots.
#' @param flip \strong{\code{\link[base]{logical}}} | Whether to invert the axis of the displayed plot.
#' @param verbose \strong{\code{\link[base]{logical}}} | Whether to show extra comments, warnings,etc.
#' @param group.by \strong{\code{\link[base]{character}}} | Metadata variable to group the output by. Has to be a character of factor column.
#' @param split.by \strong{\code{\link[base]{character}}} | Secondary metadata variable to further group (split) the output by. Has to be a character of factor column.
#' @param colors.use \strong{\code{\link[SCpubr]{named_vector}}} | Named vector of valid color representations (either name of HEX codes) with as many named colors as unique values of group.by. If group.by is not provided, defaults to the unique values of \link[Seurat]{Idents}. If not provided, a color scale will be set by default.
#' @param plot_marginal_distributions \strong{\code{\link[base]{logical}}} | Whether to plot marginal distributions on the figure or not.
#' @param marginal.type \strong{\code{\link[base]{character}}} | One of:
#' \itemize{
#' \item \emph{\code{density}}: Compute density plots on the margins.
#' \item \emph{\code{histogram}}: Compute histograms on the margins.
#' \item \emph{\code{boxplot}}: Compute boxplot on the margins.
#' \item \emph{\code{violin}}: Compute violin plots on the margins.
#' \item \emph{\code{densigram}}: Compute densigram plots on the margins.
#' }
#' @param marginal.size \strong{\code{\link[base]{numeric}}} | Size ratio between the main and marginal plots. A value of 5 means that the main plot is 5 times bigger than the marginal plots.
#' @param marginal.group \strong{\code{\link[base]{logical}}} | Whether to group the marginal distribution by group.by or current identities.
#' @param enforce_symmetry \strong{\code{\link[base]{logical}}} | Return a symmetrical plot axes-wise or continuous color scale-wise, when applicable.
#' @param column_title \strong{\code{\link[base]{character}}} | Title for the columns of the heatmaps. Only works with single heatmaps.
#' @param row_title \strong{\code{\link[base]{character}}} | Title for the rows of the heatmaps. Only works with single heatmaps.
#' @param cluster_cols \strong{\code{\link[base]{logical}}} | Cluster the columns or rows of the heatmaps.
#' @param cluster_rows \strong{\code{\link[base]{logical}}} | Cluster the rows or rows of the heatmaps.
#' @param column_names_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the column labels.
#' @param row_names_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the row labels.
#' @param cell_size \strong{\code{\link[base]{numeric}}} | Size of each cell in the heatmap.
#' @param input_gene_list \strong{\code{\link[SCpubr]{named_list}}} | Named list of lists of genes to be used as input.
#' @param column_title_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the column titles.
#' @param row_title_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the row titles.
#' @param column_names_side \strong{\code{\link[base]{character}}} | Side to put the column names. Either left or right.
#' @param row_names_side \strong{\code{\link[base]{character}}} | Side to put the row names. Either left or right.
#' @param column_title_side \strong{\code{\link[base]{character}}} | Side to put the column titles Either left or right.
#' @param row_title_side \strong{\code{\link[base]{character}}} | Side to put the row titles Either left or right.
#' @param heatmap.legend.length,heatmap.legend.width \strong{\code{\link[base]{numeric}}} | Width and length of the legend in the heatmap.
#' @param heatmap.legend.framecolor \strong{\code{\link[base]{character}}} | Color of the edges and ticks of the legend in the heatmap.
#' @param scale_direction \strong{\code{\link[base]{numeric}}} | Direction of the viridis scales. Either -1 or 1.
#' @param heatmap_gap \strong{\code{\link[base]{numeric}}} | Gap in cm between heatmaps.
#' @param legend_gap \strong{\code{\link[base]{numeric}}} | Gap in cm between legends.
#' @param cells.highlight,idents.highlight \strong{\code{\link[base]{character}}} | Vector of cells/identities to focus into. The identities have to much those in \code{Seurat::Idents(sample)} The rest of the cells will be grayed out. Both parameters can be used at the same time.
#' @param dims \strong{\code{\link[base]{numeric}}} | Vector of 2 numerics indicating the dimensions to plot out of the selected reduction. Defaults to c(1, 2) if not specified.
#' @param ncol \strong{\code{\link[base]{numeric}}} | Number of columns used in the arrangement of the output plot using "split.by" parameter.
#' @param features \strong{\code{\link[base]{character}}} | Features to represent.
#' @param feature \strong{\code{\link[base]{character}}} | Feature to represent.
#' @param use_viridis \strong{\code{\link[base]{logical}}} | Whether to use viridis color scales.
#' @param viridis.direction \strong{\code{\link[base]{numeric}}} | Either 1 or -1. Controls how the gradient of viridis scale is formed.
#' @param plot.grid \strong{\code{\link[base]{logical}}} | Whether to plot grid lines.
#' @param grid.color \strong{\code{\link[base]{character}}} | Color of the grid in the plot. In heatmaps, color of the border of the cells.
#' @param grid.type \strong{\code{\link[base]{character}}} | One of the possible linetype options:
#' \itemize{
#' \item \emph{\code{blank}}.
#' \item \emph{\code{solid}}.
#' \item \emph{\code{dashed}}.
#' \item \emph{\code{dotted}}.
#' \item \emph{\code{dotdash}}.
#' \item \emph{\code{longdash}}.
#' \item \emph{\code{twodash}}.
#' }
#' @param plot.axes \strong{\code{\link[base]{logical}}} | Whether to plot axes or not.
#' @param nbin \strong{\code{\link[base]{numeric}}} | Number of bins to use in \link[Seurat]{AddModuleScore}.
#' @param ctrl \strong{\code{\link[base]{numeric}}} | Number of genes in the control set to use in \link[Seurat]{AddModuleScore}.
#' @param repel \strong{\code{\link[base]{logical}}} | Whether to repel the text labels.
#' @param plot_density_contour \strong{\code{\link[base]{logical}}} | Whether to plot density contours in the UMAP.
#' @param contour.position \strong{\code{\link[base]{character}}} | Whether to plot density contours on top or at the bottom of the visualization layers, thus overlapping the clusters/cells or not.
#' @param contour.color \strong{\code{\link[base]{character}}} | Color of the density lines.
#' @param contour.lineend \strong{\code{\link[base]{character}}} | Line end style (round, butt, square).
#' @param contour.linejoin \strong{\code{\link[base]{character}}} | Line join style (round, mitre, bevel).
#' @param contour_expand_axes \strong{\code{\link[base]{numeric}}} | To make the contours fit the plot, the limits of the X and Y axis are expanding a given percentage from the min and max values for each axis. This controls such percentage.
#' @param min.cutoff,max.cutoff \strong{\code{\link[base]{numeric}}} | Set the min/max ends of the color scale. Any cell/group with a value lower than min.cutoff will turn into min.cutoff and any cell with a value higher than max.cutoff will turn into max.cutoff. In FeaturePlots, provide as many values as features. Use NAs to skip a feature.
#' @param label \strong{\code{\link[base]{logical}}} | Whether to plot the cluster labels in the UMAP. The cluster labels will have the same color as the cluster colors.
#' @param label.color \strong{\code{\link[base]{character}}} | Color of the labels in the plot.
#' @param label.fill \strong{\code{\link[base]{character}}} | Color to fill the labels. Has to be a single color, that will be used for all labels. If \strong{\code{NULL}}, the colors of the clusters will be used instead.
#' @param label.size \strong{\code{\link[base]{numeric}}} | Size of the labels in the plot.
#' @param label.box \strong{\code{\link[base]{logical}}} | Whether to plot the plot labels as \strong{\code{\link[ggplot2]{geom_text}}} (FALSE) or \strong{\code{\link[ggplot2]{geom_label}}} (TRUE).
#' @param min.overlap \strong{\code{\link[base]{numeric}}} | Filter the output result to the terms which are supported by this many genes.
#' @param GO_ontology \strong{\code{\link[base]{character}}} | GO ontology to use. One of:
#' \itemize{
#' \item \emph{\code{BP}}: For \strong{B}iological \strong{P}rocess.
#' \item \emph{\code{MF}}: For \strong{M}olecular \strong{F}unction.
#' \item \emph{\code{CC}}: For \strong{C}ellular \strong{C}omponent.
#' }
#' @param genes \strong{\code{\link[base]{character}}} | Vector of gene symbols to query for functional annotation.
#' @param org.db \strong{\code{OrgDB}} | Database object to use for the query.
#' @param disable_white_in_viridis \strong{\code{\link[base]{logical}}} | Remove the white in viridis color scale when \strong{\code{viridis.direction}} is set to -1.
#' @param number.breaks \strong{\code{\link[base]{numeric}}} | Controls the number of breaks in continuous color scales of ggplot2-based plots.
#' @param border.density \strong{\code{\link[base]{numeric}}} | Controls the number of cells used when \strong{\code{plot_cell_borders = TRUE}}. Value between 0 and 1. It computes a 2D kernel density and based on this cells that have a density below the specified quantile will be used to generate the cluster contour. The lower this number, the less cells will be selected, thus reducing the overall size of the plot but also potentially preventing all the contours to be properly drawn.
#' @param strip.spacing \strong{\code{\link[base]{numeric}}} | Controls the size between the different facets.
#' @param strip.text.color \strong{\code{\link[base]{character}}} | Color of the strip text.
#' @param strip.text.angle \strong{\code{\link[base]{numeric}}} | Rotation of the strip text (angles).
#' @param diverging.palette \strong{\code{\link[base]{character}}} | Type of symmetrical color palette to use. Out of the diverging palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param diverging.direction \strong{\code{\link[base]{numeric}}} | Either 1 or -1. Direction of the divering palette. This basically flips the two ends.
#' @param sequential.palette \strong{\code{\link[base]{character}}} | Type of sequential color palette to use. Out of the sequential palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param sequential.palette.pvalue,sequential.palette.expression,sequential.palette.logfc \strong{\code{\link[base]{character}}} | Sequential palettes for p-value, logfc and expression heatmaps. Type of sequential color palette to use. Out of the sequential palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param sequential.direction \strong{\code{\link[base]{numeric}}} | Direction of the sequential color scale. Either 1 or -1.
#' @param return_object \strong{\code{\link[base]{logical}}} | Returns the Seurat object with the modifications performed in the function. Nomally, this contains a new assay with the data that can then be used for any other visualization desired.
#' @param statistic \strong{\code{\link[base]{character}}} | DecoupleR statistic to use. One of:
#' \itemize{
#' \item \emph{\code{wmean}}: For weighted mean.
#' \item \emph{\code{norm_wmean}}: For normalized weighted mean.
#' \item \emph{\code{corr_wmean}}: For corrected weighted mean.
#' }
#' @param subsample \strong{\code{\link[base]{numeric}}} | Number of cells to randomly select from the Seurat object to enhance performance. Selecting NA will disable this but might lead to function breaks if the sample size is too large.
#' @param cluster \strong{\code{\link[base]{logical}}} | Whether to perform clustering of rows and columns.
#' @param subsample \strong{\code{\link[base]{numeric}}} | Number of cells to subset for the analysis. NA will use all. Cells are selected at random.
#' @param plot.title.face,plot.subtitle.face,plot.caption.face,axis.title.face,axis.text.face,legend.title.face,legend.text.face \strong{\code{\link[base]{character}}} | Controls the style of the font for the corresponding theme element. One of:
#' \itemize{
#' \item \emph{\code{plain}}: For normal text.
#' \item \emph{\code{italic}}: For text in itallic.
#' \item \emph{\code{bold}}: For text in bold.
#' \item \emph{\code{bold.italic}}: For text both in itallic and bold.
#' }
#' @param strip.text.face \strong{\code{\link[base]{character}}} | Controls the style of the font for the strip text. One of:
#' \itemize{
#' \item \emph{\code{plain}}: For normal text.
#' \item \emph{\code{italic}}: For text in itallic.
#' \item \emph{\code{bold}}: For text in bold.
#' \item \emph{\code{bold.italic}}: For text both in itallic and bold.
#' }
#' @param flavor \strong{\code{\link[base]{character}}} | One of: Seurat, UCell. Compute the enrichment scores using \link[Seurat]{AddModuleScore} or \link[UCell]{AddModuleScore_UCell}.
#' @param features.order \strong{\code{\link[base]{character}}} | Should the gene sets be ordered in a specific way? Provide it as a vector of characters with the same names as the names of the gene sets.
#' @param groups.order \strong{\code{\link[SCpubr]{named_list}}} | Should the groups in theheatmaps be ordered in a specific way? Provide it as a named list (as many lists as values in \strong{\code{group.by}}) with the order for each of the elements in the groups.
#' @param interpolate \strong{\code{\link[base]{logical}}} | Smoothes the output heatmap, saving space on disk when saving the image. However, the image is not as crisp.
#' @param order \strong{\code{\link[base]{logical}}} | Whether to order the boxplots by average values. Can not be used alongside split.by.
#' @param dot.scale \strong{\code{\link[base]{numeric}}} | Scale the size of the dots.
#' @usage NULL
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @examples
#'
#' # This a mock function that stores the documentation for many other functions.
#' # It is not intended for user usage.
doc_function <- function(sample,
font.size,
font.type,
legend.type,
legend.position,
legend.framewidth,
legend.tickwidth,
legend.framecolor,
legend.tickcolor,
legend.length,
legend.width,
plot.title,
plot.subtitle,
plot.caption,
assay,
slot,
reduction,
viridis.palette,
raster,
raster.dpi,
plot_cell_borders,
border.size,
border.color,
na.value,
axis.text.x.angle,
xlab,
ylab,
pt.size,
verbose,
flip,
group.by,
split.by,
colors.use,
legend.title,
legend.icon.size,
legend.byrow,
legend.ncol,
legend.nrow,
plot_marginal_distributions,
marginal.type,
marginal.size,
marginal.group,
enforce_symmetry,
column_title,
row_title,
cluster_cols,
cluster_rows,
column_names_rot,
row_names_rot,
cell_size,
input_gene_list,
column_title_rot,
row_title_rot,
column_names_side,
row_names_side,
column_title_side,
row_title_side,
heatmap.legend.length,
heatmap.legend.width,
heatmap.legend.framecolor,
scale_direction,
heatmap_gap,
legend_gap,
cells.highlight,
idents.highlight,
ncol,
dims,
feature,
features,
use_viridis,
viridis.direction,
plot.grid,
grid.color,
grid.type,
plot.axes,
individual.titles,
individual.subtitles,
individual.captions,
legend.title.position,
repel,
plot_density_contour,
contour.position,
contour.color,
contour.lineend,
contour.linejoin,
contour_expand_axes,
label,
label.color,
label.fill,
label.size,
label.box,
min.overlap,
GO_ontology,
genes,
org.db,
disable_white_in_viridis,
number.breaks,
strip.spacing,
strip.text.color,
strip.text.angle,
diverging.palette,
diverging.direction,
subsample,
plot.title.face,
plot.subtitle.face,
plot.caption.face,
axis.title.face,
axis.text.face,
legend.title.face,
legend.text.face,
flavor,
features.order,
groups.order,
interpolate,
order,
dot.scale){}
#' Named vector.
#'
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @usage NULL
#' @examples
#' # This is a named vector.
#' x <- c("first_element" = 3,
#' "second_element" = TRUE)
#' print(x)
#'
named_vector <- function(){}
#' Named list.
#'
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @usage NULL
#' @examples
#' # This is a named vector.
#' x <- list("first_element" = c("GENE A", "GENE B"),
#' "second_element" = c("GENE C", "GENE D"))
#' print(x)
#'
named_list <- function(){}
# Operators.
# Not in operator.
`%!in%` <- function(x, y) {return(!(x %in% y))}
# nocov start
crayon_body <- function(text){
return(cli::col_none(text))
}
add_star <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_yellow(cli::style_bold(cli::symbol$star)), " "))
} else {
return("* ")
}
}
add_info <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_cyan(cli::style_bold(cli::symbol$info)), " "))
} else {
return("i ")
}
}
add_cross <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_red(cli::style_bold(cli::symbol$cross)), " "))
} else {
return("x ")
}
}
add_warning <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n", ""), cli::col_yellow(cli::style_bold("!")), " "))
} else {
return("! ")
}
}
add_tick <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_green(cli::style_bold(cli::symbol$tick)), " "))
} else {
return("")
}
}
crayon_key <- function(text){
return(cli::col_cyan(text))
}
# nocov end
#' Return a list of SCpubr dependencies.
#'
#' @noRd
#' @return None
#' @examples
#' \donttest{
#' TBD
#' }
return_dependencies <- function(){
pkg_list <- list("Essentials" = c("Seurat",
"SeuratObject",
"rlang",
"dplyr",
"magrittr",
"dplyr",
"tidyr",
"tibble",
"stringr",
"ggplot2",
"patchwork",
"plyr",
"viridis",
"forcats",
"scales",
"assertthat",
"RColorBrewer",
"labeling",
"withr"),
"do_AffinityAnalysisPlot" = "decoupleR",
"do_AlluvialPlot" = "ggalluvial",
"do_BarPlot" = c("colorspace", "ggrepel"),
"do_BeeSwarmPlot" = c("colorspace", "ggbeeswarm", "ggrastr"),
"do_BoxPlot" = "ggsignif",
"do_CellularStatesPlot" = c("pbapply", "ggExtra", "ggplotify", "scattermore"),
"do_ChordDiagramPlot" = "circlize",
"do_ColorPalette" = NULL,
"do_CopyNumberVariantPlot" = "ggdist",
"do_CorrelationPlot" = NULL,
"do_DimPlot" = c("colorspace", "ggplotify", "scattermore"),
"do_DotPlot" = NULL,
"do_EnrichmentHeatmap" = c("UCell"),
"do_ExpressionHeatmap" = NULL,
"do_FeaturePlot" = c("scattermore", "MASS"),
"do_GeyserPlot" = "ggdist",
"do_GroupwiseDEPlot" = NULL,
"do_MetadataPlot" = "cluster",
"do_LigandReceptorPlot" = "liana",
"do_LoadingsPlot" = NULL,
"do_RankedEnrichmentPlot" = "Matrix",
"do_RankedExpressionPlot" = NULL,
"do_NebulosaPlot" = "Nebulosa",
"do_PathwayActivityPlot" = NULL,
"do_RidgePlot" = "ggridges",
"do_SCExpressionHeatmap" = NULL,
"do_SCEnrichmentHeatmap" = c("UCell"),
"do_TermEnrichmentPlot" = c("enrichplot"),
"do_TFActivityPlot" = NULL,
"do_ViolinPlot" = NULL,
"do_VolcanoPlot" = "ggrepel",
"do_WafflePlot" = "waffle",
"save_Plot" = "svglite")
return(pkg_list)
}
#' Checks for Suggests.
#'
#' @noRd
#' @return None
#' @examples
#' \donttest{
#' TBD
#' }
check_suggests <- function(function_name, passive = FALSE){
pkg_list <- return_dependencies()
# The function is not in the current list of possibilities.
if (function_name %!in% names(pkg_list)){
stop(paste0(add_cross(), crayon_key(function_name), crayon_body(" is not an accepted function name.")), call. = FALSE)
}
pkgs <- c(pkg_list[[function_name]], pkg_list[["Essentials"]])
non_seurat_functions <- c("save_Plot",
"do_VolcanoPlot",
"do_LigandReceptorPlot",
"do_ColorPalette")
if (function_name %in% non_seurat_functions){
pkgs <- pkgs[!(pkgs %in% c("Seurat", "SeuratObject"))]
}
pkgs <- vapply(pkgs, requireNamespace, quietly = TRUE, FUN.VALUE = logical(1))
# nocov start
if(sum(!pkgs) > 0){
missing_pkgs <- names(pkgs[vapply(pkgs, function(x){base::isFALSE(x)}, FUN.VALUE = logical(1))])
if (base::isFALSE(passive)){
stop(paste0(add_cross(), crayon_body("Packages "),
paste(vapply(missing_pkgs, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(" must be installed to use "),
crayon_key(function_name),
crayon_body(".")), call. = FALSE)
}
}
value <- if(sum(pkgs) != length(pkgs)){FALSE} else {TRUE}
if (isTRUE(passive)) {return(value)}
# nocov end
}
#' Generate a status report of SCpubr and its dependencies.
#'
#' This function generates a summary report of the installation status of SCpubr, which packages are still missing and which functions can or can not currently be used.
#'
#' @param startup \strong{\code{\link[base]{logical}}} | Whether the message should be displayed at startup, therefore, also containing welcoming messages and tips. If \strong{\code{FALSE}}, only the report itself will be printed.
#' @param extended \strong{\code{\link[base]{logical}}} | Whether the message should also include installed packages, current and available version, and which \strong{\code{SCpubr}} functions can be used with the currently installed packages.
#' @return None
#' @export
#'
#' @examples
#'
#' \donttest{
#' # Print a package report.
#' SCpubr::package_report(startup = FALSE, extended = FALSE)
#' }
package_report <- function(startup = FALSE,
extended = FALSE){
# nocov start
if (base::isFALSE(requireNamespace("cli", quietly = TRUE)) | base::isFALSE(requireNamespace("rlang", quietly = TRUE))){
if (base::isFALSE(startup)){
message(paste(rep("-", 63), collapse = ""))
message('This is a placeholder message. Please install "cli" and "rlang" packages to have an optimal experience using the package.')
message(paste(rep("-", 63), collapse = ""))
} else if(isTRUE(startup)){
packageStartupMessage(paste(rep("-", 63), collapse = ""))
packageStartupMessage('This is a placeholder message. Please install "cli" and "rlang" packages to have an optimal experience using the package.')
packageStartupMessage(paste(rep("-", 63), collapse = ""))
packageStartupMessage("\n\n\nSCpubr")
packageStartupMessage("\nIf you use SCpubr in your research, please cite it accordingly: \nBlanco-Carmona, E. Generating publication ready visualizations for Single Cell transcriptomics using SCpubr. bioRxiv (2022) doi:10.1101/2022.02.28.482303.\n")
packageStartupMessage("If the package is useful to you, consider leaving a Star in the GitHub repo: https://github.com/enblacar/SCpubr/stargazers \n")
packageStartupMessage("Keep track of the package updates on Twitter (@Enblacar) or in https://github.com/enblacar/SCpubr/blob/main/NEWS.md \n")
packageStartupMessage("To suppress this startup message, use: \nsuppressPackageStartupMessages(library('SCpubr'))")
packageStartupMessage(paste(rep("-", 63), collapse = ""))
}
} else {
# nocov end
tip_rule <- cli::rule(left = "General", width = nchar("General") + 6)
tutorials <- paste0(add_info(initial_newline = FALSE),
crayon_body("Have a look at extensive tutorials in "),
crayon_key(cli::style_hyperlink(text = "SCpubr's book",
url = "https://enblacar.github.io/SCpubr-book/")),
crayon_body("."))
cite <- paste0(add_tick(initial_newline = FALSE),
crayon_body("If you use "),
crayon_key("SCpubr"),
crayon_body(" in your research, please "),
crayon_key(cli::style_hyperlink(text = "cite it accordingly",
url = "https://www.biorxiv.org/content/10.1101/2022.02.28.482303v1")),
crayon_body("."))
stars <- paste0(add_star(initial_newline = FALSE),
crayon_body("If the package is useful to you, consider leaving a "),
crayon_key("Star"),
crayon_body(" in the "),
crayon_key(cli::style_hyperlink(text = "GitHub repository",
url = "https://github.com/enblacar/SCpubr")),
crayon_body("."))
updates <- paste0(cli::style_bold(cli::col_blue("!")),
crayon_body(" Keep track of the package "),
crayon_key("updates"),
crayon_body(" on Twitter ("),
crayon_key(cli::style_hyperlink(text = "@Enblacar",
url = "https://twitter.com/Enblacar")),
crayon_body(") or in the "),
crayon_key(cli::style_hyperlink(text = "Official NEWS website",
url = "https://github.com/enblacar/SCpubr/blob/main/NEWS.md")),
crayon_body("."))
plotting <- paste0(cli::style_bold(cli::col_red(cli::symbol$heart)), " ", crayon_body("Happy plotting!"))
header <- cli::rule(left = paste0(crayon_body("SCpubr "),
crayon_key(utils::packageVersion("SCpubr"))), line_col = "cadetblue")
if (isTRUE(extended)){
format_package_name <- function(package,
max_length_packages){
length.use <- max_length_packages - nchar(package)
package.use <- paste0(package, paste(rep(" ", length.use), collapse = ""))
if (isTRUE(requireNamespace(package, quietly = TRUE))){
if ((package == "ggplot2") & (utils::packageVersion(package) < "3.4.0")){
name <- paste0(cli::col_yellow(cli::style_bold("!")),
" ",
cli::col_magenta(package.use))
} else if ((package == "dplyr") & (utils::packageVersion(package) < "1.1.0")){
name <- paste0(cli::col_yellow(cli::style_bold("!")),
" ",
cli::col_magenta(package.use))
} else {
name <- paste0(cli::col_green(cli::symbol$tick),
crayon_body(" "),
crayon_body(package.use))
}
return(name)
} else {
return(paste0(cli::col_red(cli::symbol$cross),
crayon_body(" "),
cli::col_red(package.use)))
}
}
packages <- sort(unique(unlist(return_dependencies())))
max_length_packages <- max(vapply(packages, nchar, FUN.VALUE = numeric(1)))
packages_mod <- vapply(packages, function(x){format_package_name(x,
max_length_packages = max_length_packages)}, FUN.VALUE = character(1))
functions <- sort(unique(names(return_dependencies())))
if (rev(strsplit(as.character( as.character(utils::packageVersion("SCpubr"))), split = "\\.")[[1]])[1] >= 9000){
names.use <- unname(vapply(functions, function(x){if (x %in% c("do_LigandReceptorPlot",
"save_Plot",
"do_MetadataPlot",
"do_SCExpressionHeatmap",
"do_SCEnrichmentHeatmap",
"do_AffinityAnalysisPlot",
"do_DiffusionMapPlot",
"do_LoadingsPlot")){x <- paste0(x, cli::col_cyan(" | DEV"))} else {x}}, FUN.VALUE = character(1)))
functions <- vapply(functions, check_suggests, passive = TRUE, FUN.VALUE = logical(1))
names(functions) <- names.use
# nocov start
} else {
functions <- functions[!(functions %in% c("do_LigandReceptorPlot",
"save_Plot",
"do_MetadataPlot",
"do_SCExpressionHeatmap",
"do_SCEnrichmentHeatmap",
"do_AffinityAnalysisPlot",
"do_DiffusionMapPlot",
"do_LoadingsPlot"))]
functions <- vapply(functions, check_suggests, passive = TRUE, FUN.VALUE = logical(1))
}
# nocov end
functions <- functions[names(functions) != "Essentials"]
max_length_functions <- max(vapply(names(functions), nchar, FUN.VALUE = numeric(1)))
format_functions <- function(name, value, max_length){
func_use <- ifelse(isTRUE(value), cli::col_green(cli::symbol$tick), cli::col_red(cli::symbol$cross))
name_use <- ifelse(isTRUE(value),
cli::ansi_align(crayon_body(name), max_length, align = "left"),
cli::ansi_align(cli::col_red(name), max_length, align = "left"))
paste0(func_use, " ", name_use)
}
functions.use <- NULL
for(item in names(functions)){
functions.use <- append(functions.use, format_functions(name = item, value = functions[[item]], max_length = max_length_functions))
}
counter <- 0
print.list <- list()
print.list.functions <- list()
print.vector <- NULL
print.vector.functions <- NULL
for(item in packages_mod){
counter <- counter + 1
if (counter %% 4 != 0){
print.vector <- append(print.vector, item)
if (counter == length(packages)){
print.list[[item]] <- paste(print.vector, collapse = " ")
print.vector <- NULL
}
} else {
print.vector <- append(print.vector, item)
print.list[[item]] <- paste(print.vector, collapse = " ")
print.vector <- NULL
}
}
counter <- 0
for(item in functions.use){
counter <- counter + 1
if (counter %% 3 != 0){
print.vector.functions <- append(print.vector.functions, item)
if (counter == length(functions.use)){
print.list.functions[[item]] <- paste(print.vector.functions, collapse = " ")
}
} else {
print.vector.functions <- append(print.vector.functions, item)
print.list.functions[[item]] <- paste(print.vector.functions, collapse = " ")
print.vector.functions <- NULL
}
}
packages_check <- cli::rule(left = "Required packages", width = nchar("Required packages") + 6)
packages_tip1 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Installed packages are denoted by a "),
crayon_key("tick"),
crayon_body(" ("),
cli::style_bold(cli::col_green(cli::symbol$tick)),
crayon_body(") and missing packages by a "),
cli::col_red("cross"),
crayon_body(" ("),
cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(")."))
packages_tip2 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Installed packages that still require an update to correctly run "),
crayon_key("SCpubr"),
crayon_body(" have an "),
crayon_key("exclamation mark"),
crayon_body(" ("),
cli::style_bold(cli::col_yellow("!")),
crayon_body(")."))
functions_check <- cli::rule(left = "Available functions", width = nchar("Available functions") + 6)
functions_tip1 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Functions tied to "),
crayon_key("development"),
crayon_body(" builds of "),
crayon_key("SCpubr"),
crayon_body(" are marked by the ("),
cli::style_bold(cli::col_cyan("| DEV")),
crayon_body(") tag."))
functions_tip2 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" You can install development builds of "),
crayon_key("SCpubr"),
crayon_body(" by following the instructions in the "),
crayon_key(cli::style_hyperlink(text = "Releases",
url = "https://github.com/enblacar/SCpubr/releases")),
crayon_body(" page."))
}
tip_rule <- cli::rule(left = "Tips!", width = nchar("Tips!") + 6)
ins_message <- paste0(cli::style_bold(cli::col_blue("!")),
crayon_body(" Check missing dependencies with: "),
cli::style_italic(crayon_key('SCpubr::package_report(extended = TRUE)')))
tip_message <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" To remove the white and black end from continuous palettes, use: "),
cli::style_italic(crayon_key('options("SCpubr.ColorPaletteEnds" = FALSE)')))
disable_message <- paste0(cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(" To suppress this startup message, use: "),
cli::style_italic(crayon_key('suppressPackageStartupMessages(library(SCpubr))\n')),
cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(" Alternatively, you can also set the following option: "),
cli::style_italic(crayon_key('options("SCpubr.verbose" = FALSE)\n')),
crayon_body(" And then load the package normally (and faster) as: "),
cli::style_italic(crayon_key('library(SCpubr)')))
end_rule <- cli::rule(col = "cadetblue")
# Mount all individual messages into a big one that will be then be printed as a packageStartupMessage.
if (isTRUE(startup)){
if (isTRUE(extended)){
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
packages_check, "\n", "\n",
paste(print.list, collapse = "\n"), "\n", "\n",
packages_tip1, "\n",
packages_tip2, "\n", "\n", "\n", "\n",
functions_check, "\n", "\n",
paste(print.list.functions, collapse = "\n"), "\n", "\n",
functions_tip1, "\n",
functions_tip2, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
} else {
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
}
rlang::inform(msg_wrap, class = "packageStartupMessage")
} else if (base::isFALSE(startup)){
if (isTRUE(extended)){
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
packages_check, "\n", "\n",
paste(print.list, collapse = "\n"), "\n", "\n",
packages_tip1, "\n",
packages_tip2, "\n", "\n", "\n", "\n",
functions_check, "\n", "\n",
paste(print.list.functions, collapse = "\n"), "\n", "\n",
functions_tip1, "\n",
functions_tip2, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
} else {
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
}
rlang::inform(msg_wrap)
}
}
}
#' Check for Seurat class.
#'
#' @param sample Seurat object.
#'
#' @noRd
#' @return None
#'
#' @examples
#' \donttest{
#' TBD
#' }
check_Seurat <- function(sample){
assertthat::assert_that("Seurat" %in% class(sample),
msg = paste0(add_cross(), crayon_body("The provided "),
crayon_key("object"),
crayon_body(" is not a "),
crayon_key("Seurat"),
crayon_body(" object.")))
}
#' Internal check for colors.
#'
#' Adapted from: https://stackoverflow.com/a/13290832.
#
#' @param colors Vector of colors.
#' @param parameter_name The name of the parameter for which we are testing the colors.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_colors <- function(colors, parameter_name = "") {
check <- vapply(colors, function(color) {
tryCatch(is.matrix(grDevices::col2rgb(colors)),
error = function(e) FALSE)
}, FUN.VALUE = logical(1))
# Check for cols.highlight.
assertthat::assert_that(sum(check) == length(colors),
msg = paste0(add_cross(), crayon_body("The colors provided to "),
crayon_key(parameter_name),
crayon_body(" are not valid color representations.\nCheck whether they are accepted "),
crayon_key("R nammes"),
crayon_body(" or "),
crayon_key("HEX codes"),
crayon_body(".")))
}
#' Internal check for named colors and unique values of the grouping variable.
#'
#' @param sample Seurat object.
#' @param colors Named vector of colors.
#' @param grouping_variable Metadata variable in sample to obtain its unique values.
#' @param idents.keep Identities to keep from the grouping_variable.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_consistency_colors_and_names <- function(sample, colors, grouping_variable = NULL, idents.keep = NULL){
# Add lengthy error messages.
withr::local_options(.new = list("warning.length" = 8170))
if (is.null(grouping_variable)){
check_values <- levels(sample)
} else {
if (is.factor(sample@meta.data[, grouping_variable])){
check_values <- levels(sample@meta.data[, grouping_variable])
} else {
check_values <- as.character(unique(sample@meta.data[, grouping_variable]))
}
}
if (!is.null(idents.keep)){
# Remove unwanted idents.
check_values <- check_values[check_values %in% idents.keep]
}
# Remove NAs.
check_values <- check_values[!(is.na(check_values))]
# Remove values that are not in the vector.
if (sum(names(colors) %in% check_values) == length(check_values) & length(names(colors)) > length(check_values)){
colors <- colors[names(colors) %in% check_values]
}
if (base::isFALSE(length(colors) == length(check_values)) | base::isFALSE(sum(names(colors) %in% check_values) == length(check_values))){
format_colors <- function(name, value, colors, max_length){
if (name %in% names(colors)){
name <- paste(c(name, crayon_body(" | "), cli::col_cyan(paste0(colors[[name]]))), collapse = "")
}
func_use <- ifelse(isTRUE(value), cli::col_green(cli::symbol$tick), cli::col_red(cli::symbol$cross))
name_use <- ifelse(isTRUE(value),
cli::ansi_align(crayon_key(name), max_length, align = "left"),
cli::ansi_align(cli::col_red(name), max_length, align = "left"))
paste0(func_use, " ", name_use)
}
color_check <- vapply(check_values, function(x){ifelse(x %in% names(colors), TRUE, FALSE)}, FUN.VALUE = logical(1))
max_length <- max(vapply(check_values, nchar, FUN.VALUE = numeric(1)))
max_length_colors <- max(vapply(unname(colors), nchar, FUN.VALUE = numeric(1)))
length.use <- max_length + 3 + max_length_colors
colors.print <- NULL
for(item in sort(names(color_check))){
colors.print <- append(colors.print, format_colors(name = item, colors = colors, value = color_check[[item]], max_length = length.use))
}
msg <- paste0("\n", "\n",
add_cross(),
crayon_body("The "),
crayon_key("number"),
crayon_body(" or "),
crayon_key("names"),
crayon_body(" of the provided "),
crayon_key("colors"),
crayon_body(" is lower than the "),
crayon_key("number of unique values"),
crayon_body(" in "),
crayon_key("group.by"),
crayon_body(" (which defaults to "),
cli::style_italic(crayon_key("Seurat::Idents(sample)")),
crayon_body(" if "),
crayon_key("NULL"),
crayon_body(")."),
"\n",
add_cross(),
crayon_body("Please check that the "),
crayon_key("colors provided"),
crayon_body(" are a "),
crayon_key("named vector"),
crayon_body(" where the names are the "),
crayon_key("unique values"),
crayon_body(" to which you then assign the "),
crayon_key("colors"),
crayon_body(" to."),
"\n", "\n",
add_warning(),
crayon_body("Example: "),
cli::style_italic(crayon_key('colors.use = c("A" = "red", "B" = "blue")')),
"\n",
"\n", "\n",
crayon_body(cli::rule(left = paste0(crayon_key("Values"), crayon_body(" with an "), cli::col_cyan("assigned color")), width = nchar("Values with an assigned color") + 6)),
"\n", "\n",
paste(colors.print, collapse = "\n"), "\n", "\n")
stop(msg, call. = FALSE)
}
return(colors)
}
#' Generate custom color scale.
#'
#' @param names_use Vector of the names that will go alongside the color scale.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
generate_color_scale <- function(names_use){
# Generate a vector of colors equal to the number of identities in the sample.
colors <- colorspace::qualitative_hcl(length(names_use), palette = "Dark 3")
colors <- grDevices::col2rgb(colors)
colors <- grDevices::rgb2hsv(colors)
colors["v", ] <- colors["v", ] - 0.1
colors["s", ] <- colors["s", ] + 0.2
colors["s", ][colors["s", ] > 1] <- 1
colors <- grDevices::hsv(h = colors["h", ],
s = colors["s", ],
v = colors["v", ],
alpha = 1)
names(colors) <- names_use
return(colors)
}
#' Compute the max and min value of a variable provided to FeaturePlot.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param assay Assay used.
#' @param reduction Reduction used.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_scale_limits <- function(sample, feature, assay = NULL, reduction = NULL, slot = NULL){
if (is.null(assay)){
assay <- Seurat::DefaultAssay(sample)
}
if (is.null(reduction)){
for(red in Seurat::Reductions(object = sample)){
if (feature %in% colnames(sample@reductions[[red]][[]])){
reduction <- red
}
}
}
if (is.null(slot)){
slot <- "data"
}
if (feature %in% rownames(sample)){
suppressWarnings({
data.check <- SeuratObject::GetAssayData(sample,
assay = assay,
slot = slot)[feature, ]
})
scale.begin <- min(data.check, na.rm = TRUE)
scale.end <- max(data.check, na.rm = TRUE)
} else if (feature %in% colnames(sample@meta.data)){
if (is.factor(sample@meta.data[, feature])){
sample@meta.data[, feature] <- as.character(sample@meta.data[, feature])
}
scale.begin <- min(sample@meta.data[, feature], na.rm = TRUE)
scale.end <- max(sample@meta.data[, feature], na.rm = TRUE)
} else if (feature %in% colnames(sample@reductions[[reduction]][[]])){
scale.begin <- min(sample@reductions[[reduction]][[]][, feature], na.rm = TRUE)
scale.end <- max(sample@reductions[[reduction]][[]][, feature], na.rm = TRUE)
}
return(list("scale.begin" = scale.begin,
"scale.end" = scale.end))
}
#' Check cutoffs
#'
#' @param min.cutoff Min cutoff.
#' @param max.cutoff Max cutoff.
#' @param limits Computed range.
#' @param feature Feature name, if any.
#' @return A list.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_cutoffs <- function(min.cutoff,
max.cutoff,
limits,
feature = ""){
outlier.data <- FALSE
if (!is.na(min.cutoff) & !is.na(max.cutoff)){
assertthat::assert_that(min.cutoff < max.cutoff,
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(") has to be lower than the value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(").")))
}
if (!is.na(min.cutoff)){
assertthat::assert_that(min.cutoff >= limits[1],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") is lower than the minimum value ("),
crayon_key(limits[1]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
assertthat::assert_that(min.cutoff <= limits[2],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") is higher than the maximum value ("),
crayon_key(limits[2]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
limits <- c(min.cutoff, limits[2])
outlier.data <- TRUE
}
if (!is.na(max.cutoff)){
assertthat::assert_that(max.cutoff <= limits[2],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(") is higher than the maximum value ("),
crayon_key(limits[2]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
assertthat::assert_that(max.cutoff >= limits[1],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(") is lower than the minimum value ("),
crayon_key(limits[1]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
limits <- c(limits[1], max.cutoff)
outlier.data <- TRUE
}
return.list <- list("outlier.data" = outlier.data,
"limits" = limits)
return(return.list)
}
#' Compute the scales for a given ggplot2-based plot.
#'
#' @param sample Seurat object.
#' @param feature Feature to compute scales to.
#' @param assay Assay to retrieve data from.
#' @param reduction Reduction to use if the feature is a dimred component.
#' @param slot Slot to retrieve the values from if feature is a gene.
#' @param flavor Whether it is a seurat plot or ggplot2-based plots.
#' @param number.breaks Number of desired breaks in the scale.
#' @param min.cutoff Minimum cutoff for the scale.
#' @param max.cutoff Maximum cutoff for the scale.
#' @param from_data Provide a matrix already.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_scales <- function(sample,
feature = "",
assay = NULL,
reduction = NULL,
slot,
flavor,
number.breaks,
min.cutoff,
max.cutoff,
enforce_symmetry,
from_data = FALSE,
limits.use = NULL,
center_on_value = FALSE,
value_center = NULL){
if (base::isFALSE(from_data)){
limits <- compute_scale_limits(sample = sample,
feature = feature,
assay = assay,
reduction = reduction,
slot = slot)
limits <- c(limits$scale.begin, limits$scale.end)
} else {
limits <- limits.use
}
out <- check_cutoffs(min.cutoff = min.cutoff,
max.cutoff = max.cutoff,
limits = limits,
feature = feature)
limits <- out$limits
if (isTRUE(enforce_symmetry)){
if (base::isFALSE(center_on_value)){
end_value <- max(abs(limits))
limits <- c(-end_value, end_value)
} else {
low_end <- value_center - limits[1]
high_end <- limits[2] - value_center
value.use <- max(c(low_end, high_end))
limits <- c(1 - value.use, 1 + value.use)
}
}
breaks <- labeling::extended(dmin = limits[1],
dmax = limits[2],
m = number.breaks)
labels <- as.character(breaks)
if (!is.na(min.cutoff)){
if (isTRUE(min.cutoff == breaks[1])){
breaks[1] <- min.cutoff
labels[1] <- paste0(as.character(expression("\u2264")), " ", min.cutoff)
}
}
if (!is.na(max.cutoff)){
if (isTRUE(max.cutoff == breaks[length(breaks)])){
breaks[length(breaks)] <- max.cutoff
labels[length(labels)] <- paste0(as.character(expression("\u2265")), " ", max.cutoff)
}
}
# Fix for the one value limit.
if(limits[[1]] == limits[[2]]){
breaks <- limits[[1]]
labels <- as.character(limits[[1]])
}
return.obj <- list("limits" = limits,
"breaks" = breaks,
"labels" = labels)
return(return.obj)
}
#' Check if a value is in the range of the values.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param assay Assay used.
#' @param reduction Reduction used.
#' @param value Value to check.
#' @param value_name Name of the value.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_limits <- function(sample, feature, value_name, value, assay = NULL, reduction = NULL){
limits <- compute_scale_limits(sample = sample, feature = feature, assay = assay, reduction = reduction)
assertthat::assert_that(limits[["scale.begin"]] <= value & limits[["scale.end"]] >= value,
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key(value_name),
crayon_body(" ("),
crayon_key(value),
crayon_body(") is not in the range of values of "),
crayon_key(feature),
crayon_body(", whis is:\nMin: "),
crayon_key(limits[["scale.begin"]]),
crayon_body(".\nMax:"),
crayon_key(limits[["scale.end"]]),
crayon_body(".")))
}
#' Check if the feature to plot is in the Seurat object.
#'
#' @param sample Seurat object.
#' @param features Feature to plot.
#' @param dump_reduction_names Whether to return the reduction colnames.
#' @param permissive Throw a warning or directly stops if the feature is not found.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_feature <- function(sample, features, permissive = FALSE, dump_reduction_names = FALSE, enforce_check = NULL, enforce_parameter = NULL){
if (is.list(features)){
features_check <- unlist(features)
} else {
features_check <- features
}
check_enforcers <- list() # Store the results of the checks.
not_found_features <- NULL # Store the features not found.
# Check each of the features.
for (feature in features_check){
check <- 0
if (!(feature %in% rownames(sample))){
check <- check + 1
check_enforcers[["gene"]] <- FALSE
} else {
check_enforcers[["gene"]] <- TRUE
}
if (!(feature %in% colnames(sample@meta.data))){
check <- check + 1
check_enforcers[["metadata"]] <- FALSE
} else {
check_enforcers[["metadata"]] <- TRUE
}
dim_colnames <- NULL
for(red in Seurat::Reductions(object = sample)){
dim_colnames <- append(dim_colnames, colnames(sample@reductions[[red]][[]]))
}
if (!(feature %in% dim_colnames)){
check <- check + 1
check_enforcers[["reductions"]] <- FALSE
} else {
check_enforcers[["reductions"]] <- TRUE
}
if (check == 3) {
not_found_features <- append(not_found_features, feature)
}
}
# Return the error logs if there were features not found.
if (length(not_found_features) > 0){
if (isTRUE(permissive)){
# Stop if neither of the features are found.
assertthat::assert_that(length(unlist(not_found_features)) != length(unlist(features)),
msg = "Neither of the provided features are found.")
warning(paste0(add_warning(), crayon_body("The following "),
crayon_key("features"),
crayon_body(" were not be found:"),
paste(vapply(not_found_features, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")), call. = FALSE)
features_out <- remove_not_found_features(features = features, not_found_features = not_found_features)
} else if (base::isFALSE(permissive)){
assertthat::assert_that(length(not_found_features) == 0,
msg = paste0(add_cross(), crayon_body("The following "),
crayon_key("features"),
crayon_body(" were not be found:"),
paste(vapply(not_found_features, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
}
} else {
features_out <- features
}
# If we are enforcing a given check (i.e: the feature being in the metadata).
if (!(is.null(enforce_check))){
assertthat::assert_that(enforce_check %in% names(check_enforcers),
msg = "The variable enforcer is not in the current list of checked variable types.")
assertthat::assert_that(isTRUE(check_enforcers[[enforce_check]]),
msg = paste0(add_cross(), crayon_body("Feature "),
crayon_key(enforce_parameter),
crayon_key(" = "),
crayon_key(feature),
crayon_body(" not found in "),
crayon_key(enforce_check),
crayon_body(".")))
}
# Return options.
if (isTRUE(dump_reduction_names) & base::isFALSE(permissive)){return(dim_colnames)}
if (isTRUE(permissive) & base::isFALSE(dump_reduction_names)){return(features_out)}
if (isTRUE(dump_reduction_names) & isTRUE(permissive)){return(list("features" = features_out, "reduction_names" = dim_colnames))}
}
#' Remove not found features
#'
#' @param features Features to check.
#' @param not_found_features Features to exclude.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
remove_not_found_features <- function(features, not_found_features){
if (is.character(features)){
features_out <- features[!(features %in% not_found_features)]
} else if (is.list(features)){
features_out <- list()
for (list_name in names(features)){
genes <- features[[list_name]]
genes_out <- genes[!(genes %in% not_found_features)]
features_out[[list_name]] <- genes_out
}
}
return(features_out)
}
#' Remove duplicated features.
#'
#' @param features Features to check.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
remove_duplicated_features <- function(features){
if (is.character(features)){
check <- sum(duplicated(features))
if (check > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(features[duplicated(features)])),
crayon_body(".\nExcluding them from the analysis.")), call. = FALSE)
features <- features[!(duplicated(features))]
}
} else if (is.list(features)){
features_out <- list()
all_genes <- NULL # Will update with the genes as they iterate to check duplicates.
for (list_name in names(features)){
genes <- features[[list_name]]
# Remove genes duplicated within the list.
if (sum(duplicated(genes)) > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(genes[duplicated(genes)], collapse = ", ")),
crayon_body("\nIn the list named: "),
crayon_key(list_name),
crayon_body(".\nExcluding them from the analysis.")), call. = FALSE)
}
genes <- genes[!(duplicated(genes))]
# Remove genes duplicated in the vector of all genes.
duplicated_features <- genes[genes %in% all_genes]
all_genes <- append(all_genes, genes[!(genes %in% all_genes)])
genes <- genes[!(genes %in% duplicated_features)]
if (length(duplicated_features) > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(duplicated_features, collapse = ", ")),
crayon_body("\nIn the list named: "),
crayon_key(list_name),
crayon_body(" with regards to the other lists. \nExcluding them from the analysis.")), call. = FALSE)
}
features_out[[list_name]] <- genes
}
features <- features_out
}
return(features)
}
#' Check if the identity provided is in the current Seurat identities.
#'
#' @param sample Seurat object.
#' @param identities Identities to test.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_identity <- function(sample, identities){
for (identity in identities){
assertthat::assert_that(identity %in% levels(sample),
msg = paste0(add_cross(), crayon_body("Could not find identity "),
crayon_key(identity),
crayon_body(" in the current active identities of the object.")))
}
}
#' Check the reduction provided and set it up.
#'
#' @param sample Seurat sample.
#' @param reduction Reduction.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_reduction <- function(sample, reduction = NULL){
# Check if the object has a reduction computed.
assertthat::assert_that(length(Seurat::Reductions(sample)) != 0,
msg = paste0(add_cross(), crayon_body("The Seurat object has no "),
crayon_key("reductions"),
crayon_body(" computed.")))
# If no reduction was provided by the user.
if (is.null(reduction)){
# Select umap if computed.
if ("umap" %in% Seurat::Reductions(sample)){
reduction <- "umap"
} else {
# Select the last computed one.
reduction <- Seurat::Reductions(sample)[length(Seurat::Reductions(sample))]
}
# If the user provided a value for reduction.
} else if (!(is.null(reduction))){
# Check if the provided reduction is in the list.
assertthat::assert_that(reduction %in% Seurat::Reductions(sample),
msg = paste0(add_cross(), crayon_body("The provided "),
crayon_key("reduction"),
crayon_body(" could not be found in the object: "),
crayon_key(reduction),
crayon_body(".")))
}
return(reduction)
}
#' Check the provided dimensions and set them up.
#'
#' @param sample Seurat object.
#' @param reduction Provided reduction.
#' @param dims Provided dimensions.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_dimensions <- function(sample, reduction = NULL, dims = NULL){
# If reduction is null, select the last computed one.
if (is.null(reduction)){
reduction <- Seurat::Reductions(sample)[length(Seurat::Reductions(sample))]
}
# Check that the dimensions is a 2 item vector.
if (!is.null(dims)){
assertthat::assert_that(length(dims) == 2,
msg = paste0(add_cross(), crayon_body("You need to provide a vector of "),
crayon_key("two values"),
crayon_body(" to "),
crayon_key("dims"),
crayon_body(".")))
# Check that at least 2 dimensions are present.
aval_dims <- length(colnames(Seurat::Embeddings(sample[[reduction]])))
assertthat::assert_that(aval_dims >= 2,
msg = paste0(add_cross(), crayon_body("There need to be at least "),
crayon_key("two available dimensions"),
crayon_body(" computed.")))
# Check that the dimensions are integers.
null_check <- is.null(dims[1]) & is.null(dims[2])
integer_check <- is.numeric(dims[1]) & is.numeric(dims[1])
assertthat::assert_that(base::isFALSE(null_check) & isTRUE(integer_check),
msg = paste0(add_cross(), crayon_body("The dimensions provided to "),
crayon_key("dims"),
crayon_body(" need to be of class "),
crayon_key("numeric"),
crayon_body(".")))
# Check that the dimensions are in the requested embedding.
assertthat::assert_that(dims[1] %in% seq_len(aval_dims) & dims[2] %in% seq_len(aval_dims),
msg = paste0(add_cross(), crayon_body("The dimensions provided to "),
crayon_key("dims"),
crayon_body(" could not be found in the following reduction: "),
crayon_key(reduction),
crayon_body(".")))
} else {
# If no dimensions were provided, fall back to first and second.
dims <- c(1, 2)
}
return(dims)
}
#' Check and set the provided assay.
#'
#' @param sample Seurat object.
#' @param assay Provided assay.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_assay <- function(sample, assay = NULL){
# Check that at least one assay is computed.
assertthat::assert_that(length(Seurat::Assays(sample)) != 0,
msg = paste0(add_cross(), crayon_body("There must be at least "),
crayon_key("one computed assay"),
crayon_body(" in the Seurat object.")))
# If assay is null, set it to the active one.
if (is.null(assay)){
assay <- Seurat::DefaultAssay(sample)
} else {
# Check if the assay is a character.
assertthat::assert_that(is.character(assay),
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key("assay"),
crayon_body(" needs to of class "),
crayon_key("character"),
crayon_body(".")))
# Check that the assay is in the available assays.
aval_assays <- Seurat::Assays(sample)
assertthat::assert_that(assay %in% aval_assays,
msg = paste0(add_cross(), crayon_body("The following "),
crayon_key("assay"),
crayon_body(" was not found: "),
crayon_key(assay),
crayon_body(".")))
}
# Set up the assay the user has defined.
if (assay != Seurat::DefaultAssay(sample)){
Seurat::DefaultAssay(sample) <- assay
}
return(list("sample" = sample,
"assay" = assay))
}
#' Check a parameter for a given class.
#'
#' @param parameters List of named parameters to test.
#' @param required_type Name of the required class.
#' @param test_function Testing function.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_type <- function(parameters, required_type, test_function){
for(parameter_name in names(parameters)){
# Get each individual parameter from the list.
parameter <- parameters[[parameter_name]]
# Cases in which the user has to provide a vector.
# Check if the parameter is not NULL already.
if (!(is.null(parameter))){
# For each parameter in the vector.
for (item in parameter){
# If not null.
if (!(is.null(item))){
# If not NA, if the testing function fails, report it.
if (sum(!(is.na(item))) > 0){
assertthat::assert_that(sum(test_function(item)) > 0,
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key(parameter_name),
crayon_body(" needs to be of class "),
crayon_key(required_type),
crayon_body(".")))
}
}
}
}
}
}
#' Check the slots.
#'
#' @param slot Slot provided.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_slot <- function(slot){
if (is.null(slot)){
slot <- "data"
} else {
assertthat::assert_that(slot %in% c("counts", "data", "scale.data"),
msg = paste0(crayon_body("Parameter "),
crayon_key("slots"),
crayon_body(" needs to be either "),
crayon_key("counts"),
crayon_body(", "),
crayon_key("data"),
crayon_body(", or "),
crayon_key("scale.data"),
crayon_body(".")))
}
return(slot)
}
#' Compute the order of the plotted bars for do_BarPlot.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param group.by Feature to group the output by.
#' @param order Whether to arrange the values.
#' @param order.by Unique value in group.by to reorder labels in descending order.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_factor_levels <- function(sample, feature, position, group.by = NULL, order = FALSE, order.by = FALSE, assay = "SCT", slot = "data"){
`%>%` <- magrittr::`%>%`
assertthat::assert_that(position %in% c("stack", "fill"),
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key("position"),
crayon_body(" needs to be either "),
crayon_key("stack"),
crayon_body(" or "),
crayon_key("fill"),
crayon_body(".")))
if (is.null(group.by)){
sample@meta.data[, "group.by"] <- sample@active.ident
} else {
sample@meta.data[, "group.by"] <- sample@meta.data[, group.by]
}
group.by <- "group.by"
if (base::isFALSE(order)){
factor_levels <- as.character(rev(sort(unique(sample@meta.data[, group.by]))))
} else if (isTRUE(order)){
factor_levels <- get_data_column_in_context(sample = sample,
feature = feature,
group.by = group.by,
assay = assay,
slot = slot) %>%
dplyr::group_by(.data$group.by) %>%
dplyr::summarise("value" = if(is.double(.data$feature)){dplyr::across(.cols = dplyr::all_of("feature"), mean)} else {"feature" <- dplyr::n()}) %>%
dplyr::mutate("feature" = if (position == "fill") {.data$value / sum(.data$value)} else {.data$value}) %>%
dplyr::arrange(dplyr::desc(.data$feature)) %>%
dplyr::pull(.data$group.by) %>%
as.character()
}
return(factor_levels)
}
#' Check length of parameters compared to features.
#'
#' @param vector_of_parameters Vector of parameters to test.
#' @param vector_of_features Vector of features to test against.
#' @param parameters_name Name of the parameters variable.
#' @param features_name Name of the features variable.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_length <- function(vector_of_parameters,
vector_of_features,
parameters_name,
features_name){
assertthat::assert_that(length(vector_of_parameters) == length(vector_of_features),
msg = paste0(add_cross(), crayon_body("The length of "),
crayon_key(parameters_name),
crayon_body(" is not equal to the length of "),
crayon_key(features_name),
crayon_body(".")))
}
#' Add viridis color scale while suppressing the warning that comes with adding a second scale.
#'
#' @param p GGplot2 plot.
#' @param num_plots Number of plots.
#' @param function_use Coloring function to use.
#' @param scale Name of the scale. Either fill or color.
#' @param limits Whether to put limits.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
add_scale <- function(p, scale, function_use, num_plots = 1, limits = NULL){
if (scale == "color"){scale <- "colour"}
# Compute the number of plots in this object (maybe a more efficient solution exists).
if (num_plots == 1){
# Find the index in which the scale is stored.
# Adapted from: https://stackoverflow.com/a/46003178
x <- which(vapply(p$scales$scales, function(x){scale %in% x$aesthetics}, FUN.VALUE = logical(1)))
# Remove it.
p$scales$scales[[x]] <- NULL
} else {
for (i in seq(1, num_plots)){
# Find the index in which the scale is stored.
# Adapted from: https://stackoverflow.com/a/46003178
x <- which(vapply(p[[i]]$scales$scales, function(x){scale %in% x$aesthetics}, FUN.VALUE = logical(1)))
# Remove it.
p[[i]]$scales$scales[[x]] <- NULL
}
}
# Add the scale and now it will now show up a warning since we removed the previous scale.
p <- p & function_use
return(p)
}
#' Modify a string to wrap it around the middle point.
#'
#' @param string_to_modify
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
modify_string <- function(string_to_modify){
words <- stringr::str_split(string_to_modify, " ")[[1]]
num_words <- length(words)
middle_point <- round(num_words / 2, 0)
string_to_modify <- paste(paste(words[1:middle_point], collapse = " "), "\n",
paste(words[(middle_point + 1):num_words], collapse = " "))
return(string_to_modify)
}
#' Compute Enrichment scores using Seurat::AddModuleScore()
#'
#' @param sample Seurat object.
#' @param input_gene_list Named list of genes to compute enrichment for.
#' @param verbose Verbose output.
#' @param nbin Number of bins.
#' @param ctrl Number of control genes.
#' @param norm_data Whether to 0-1 normalize the data
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_enrichment_scores <- function(sample,
input_gene_list,
verbose = FALSE,
nbin = 24,
ctrl = 100,
assay = NULL,
slot = NULL,
flavor = "Seurat",
ncores = 1,
storeRanks = TRUE,
norm_data = FALSE){
`%>%` <- magrittr::`%>%`
# Checks for UCell.
if (flavor == "UCell"){
R_version <- paste0(R.version$major, ".", R.version$minor)
assertthat::assert_that(R_version >= "4.2.0",
msg = paste0(crayon_body("To run "),
crayon_key("UCell scoring"),
crayon_body(", R version "),
crayon_key("4.2.0"),
crayon_body(" is required. Please select "),
crayon_key("flavor = 'Seurat'"),
crayon_body(" if you are running a lower version.")))
if (!requireNamespace("UCell", quietly = TRUE)) {
# nocov start
stop(paste0(add_cross(), crayon_body("Package "), crayon_key("UCell"), crayon_body(" must be installed to run UCell scoring.")), call. = FALSE)
# nocov end
}
}
if (!is.list(input_gene_list) & is.character(input_gene_list)){
input_gene_list <- list("Input" = input_gene_list)
}
for (celltype in names(input_gene_list)){
list_markers <- list(input_gene_list[[celltype]])
if (flavor == "Seurat"){
# Compute Seurat AddModuleScore as well.
if (verbose){
sample <- Seurat::AddModuleScore(sample,
list_markers,
name = celltype,
search = TRUE,
verbose = TRUE,
nbin = nbin,
ctrl = ctrl,
assay = assay)
} else {
sample <- suppressMessages(suppressWarnings(Seurat::AddModuleScore(sample,
list_markers,
name = celltype,
search = TRUE,
verbose = FALSE,
nbin = nbin,
ctrl = ctrl,
assay = assay)))
}
# Retrieve the scores.
col_name <- stringr::str_replace_all(paste0(celltype, "1"), " ", ".")
col_name <- stringr::str_replace_all(col_name, "-", ".")
col_name <- stringr::str_replace_all(col_name, "\\+", ".")
# Modify the name that Seurat::AddModuleScore gives by default.
sample@meta.data[, celltype] <- sample@meta.data[, col_name]
# Remove old metadata.
sample@meta.data[, col_name] <- NULL
}
}
if (flavor == "UCell"){
list.names <- NULL
for (celltype in names(input_gene_list)){
col_name <- celltype
col_name <- stringr::str_replace_all(col_name, "-", ">")
col_name <- stringr::str_replace_all(col_name, " ", "_")
col_name <- stringr::str_replace_all(col_name, "\\+", ".")
list.names <- append(list.names, col_name)
}
list.originals <- names(input_gene_list)
names(input_gene_list) <- list.names
sample <- UCell::AddModuleScore_UCell(obj = sample,
features = input_gene_list,
assay = assay,
slot = if (is.null(slot)){"data"} else {slot},
name = "",
ncores = ncores,
storeRanks = storeRanks)
for (i in seq_len(length(list.names))){
old.name <- list.originals[i]
mod.name <- list.names[i]
# Modify the name that Seurat::AddModuleScore gives by default.
sample@meta.data[, old.name] <- sample@meta.data[, mod.name]
# Remove old metadata.
if (old.name != mod.name){
# nocov start
sample@meta.data[, mod.name] <- NULL
# nocov end
}
}
}
if (isTRUE(norm_data)){
# Compute a 0-1 normalization.
for (name in names(input_gene_list)){
sample@meta.data[, name] <- zero_one_norm(sample@meta.data[, name])
}
}
return(sample)
}
#' Modify the aspect of the legend.
#'
#' @param p Plot.
#' @param legend.aes Character. Either color or fill.
#' @param legend.type Character. Type of legend to display. One of: normal, colorbar.
#' @param legend.position Position of the legend in the plot. Will only work if legend is set to TRUE.
#' @param legend.framewidth,legend.tickwidth Width of the lines of the box in the legend.
#' @param legend.framecolor,legend.tickcolor Color of the lines of the box in the legend.
#' @param legend.length,legend.width Length and width of the legend. Will adjust automatically depending on legend side.
#' @param legend.title Character. Title for the legend.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
modify_continuous_legend <- function(p,
legend.aes,
legend.type,
legend.position,
legend.length,
legend.width,
legend.framecolor,
legend.tickcolor,
legend.tickwidth,
legend.framewidth,
legend.title = NULL){
# Define legend parameters. Width and height values will change depending on the legend orientation.
if (legend.position %in% c("top", "bottom", "none")){
legend.barwidth <- legend.length
legend.barheight <- legend.width
} else if (legend.position %in% c("left", "right")){
legend.barwidth <- legend.width
legend.barheight <- legend.length
}
legend.title <- if (is.null(legend.title)){ggplot2::waiver()} else {legend.title}
if (legend.aes == "color" | legend.aes == "colour"){
if (legend.type == "normal"){
p <- p +
ggplot2::guides(color = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
title.hjust = 0.5))
} else if (legend.type == "colorbar"){
p <- p +
ggplot2::guides(color = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
barwidth = legend.barwidth,
barheight = legend.barheight,
title.hjust = 0.5,
ticks.linewidth = legend.tickwidth,
frame.linewidth = legend.framewidth,
frame.colour = legend.framecolor,
ticks.colour = legend.tickcolor))
}
} else if (legend.aes == "fill"){
if (legend.type == "normal"){
p <- p +
ggplot2::guides(fill = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
title.hjust = 0.5))
} else if (legend.type == "colorbar"){
p <- p +
ggplot2::guides(fill = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
barwidth = legend.barwidth,
barheight = legend.barheight,
title.hjust = 0.5,
ticks.linewidth = legend.tickwidth,
frame.linewidth = legend.framewidth,
frame.colour = legend.framecolor,
ticks.colour = legend.tickcolor))
}
}
return(p)
}
#' Return a column with the desired values of a feature per cell.
#'
#' @param sample Seurat object.
#' @param feature Feature to retrieve data.
#' @param assay Assay to pull data from.
#' @param slot Slot from the assay to pull data from.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_data_column <- function(sample,
feature,
assay,
slot){
`%>%` <- magrittr::`%>%`
dim_colnames <- NULL
for(red in Seurat::Reductions(object = sample)){
col.names <- colnames(sample@reductions[[red]][[]])
dim_colnames <- append(dim_colnames, col.names)
if (feature %in% col.names){
# Get the reduction in which the feature is, if this is the case.
reduction <- red
}
}
if (isTRUE(feature %in% colnames(sample@meta.data))){
feature_column <- sample@meta.data %>%
dplyr::select(dplyr::all_of(c(feature))) %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
} else if (isTRUE(feature %in% rownames(sample))){
suppressWarnings({
feature_column <- SeuratObject::GetAssayData(object = sample,
assay = assay,
slot = slot)[feature, , drop = FALSE] %>%
as.matrix() %>%
t() %>%
as.data.frame() %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
})
} else if (isTRUE(feature %in% dim_colnames)){
feature_column <- sample@reductions[[reduction]][[]][, feature, drop = FALSE] %>%
as.data.frame() %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
}
return(feature_column)
}
#' Return a column with the desired values of a feature per cell.
#'
#' @param sample Seurat object.
#' @param feature Feature to retrieve data.
#' @param assay Assay to pull data from.
#' @param group.by Parameter used later on for grouping.
#' @param split.by Parameter used later on for splitting.
#' @param slot Slot from the assay to pull data from.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_data_column_in_context <- function(sample,
feature,
assay,
slot,
group.by = NULL,
split.by = NULL){
`%>%` <- magrittr::`%>%`
if (is.null(group.by)){
sample@meta.data[, "group.by"] <- sample@active.ident
} else {
sample@meta.data[, "group.by"] <- sample@meta.data[, group.by]
}
group.by <- "group.by"
vars <- c("cell", "group.by")
if (!is.null(split.by)){
sample@meta.data[, "split.by"] <- sample@meta.data[, split.by]
vars <- c(vars, "split.by")
}
data <- sample@meta.data %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::select(dplyr::all_of(vars)) %>%
dplyr::left_join(y = get_data_column(sample = sample,
feature = feature,
assay = assay,
slot = slot),
by = "cell") %>%
tibble::as_tibble()
return(data)
}
#' Check parameters.
#'
#' @param parameter Parameter to check
#' @param parameter_name Name of the parameter.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_parameters <- function(parameter,
parameter_name){
if (parameter_name == "font.type"){
# Check font.type.
assertthat::assert_that(parameter %in% c("sans", "serif", "mono"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("sans"),
crayon_body(", "),
crayon_key("serif"),
crayon_body(", "),
crayon_key("mono"),
crayon_body(".")))
} else if (parameter_name == "legend.type"){
# Check the legend.type.
assertthat::assert_that(parameter %in% c("normal", "colorbar"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("normal"),
crayon_body(", "),
crayon_key("colorbar"),
crayon_body(".")))
} else if (parameter_name == "legend.position"){
# Check the legend.position.
assertthat::assert_that(parameter %in% c("top", "bottom", "left", "right", "none"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("top"),
crayon_body(", "),
crayon_key("bottom"),
crayon_body(", "),
crayon_key("left"),
crayon_body(", "),
crayon_key("right"),
crayon_body(", "),
crayon_key("none"),
crayon_body(".")))
} else if (parameter_name == "marginal.type"){
# Check marginal.type.
assertthat::assert_that(parameter %in% c("density", "histogram", "boxplot", "violin", "densigram"),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("density"),
crayon_body(", "),
crayon_key("histogram"),
crayon_body(", "),
crayon_key("boxplot"),
crayon_body(", "),
crayon_key("violin"),
crayon_body(", "),
crayon_key("densigram"),
crayon_body(".")))
} else if (parameter_name == "viridis.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "sequential.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "diverging.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "viridis.palette"){
viridis_options <- c("A", "B", "C", "D", "E", "F", "G", "H", "magma", "inferno", "plasma", "viridis", "cividis", "rocket", "mako", "turbo")
assertthat::assert_that(parameter %in% viridis_options,
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("A"),
crayon_body(", "),
crayon_key("B"),
crayon_body(", "),
crayon_key("C"),
crayon_body(", "),
crayon_key("D"),
crayon_body(", "),
crayon_key("E"),
crayon_body(", "),
crayon_key("F"),
crayon_body(", "),
crayon_key("G"),
crayon_body(", "),
crayon_key("H"),
crayon_body(", "),
crayon_key("magma"),
crayon_body(", "),
crayon_key("inferno"),
crayon_body(", "),
crayon_key("plasma"),
crayon_body(", "),
crayon_key("viridis"),
crayon_body(", "),
crayon_key("cividis"),
crayon_body(", "),
crayon_key("rocket"),
crayon_body(", "),
crayon_key("mako"),
crayon_body(", "),
crayon_key("turbo"),
crayon_body(".")))
} else if (parameter_name == "grid.type"){
assertthat::assert_that(parameter %in% c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("blank"),
crayon_body(", "),
crayon_key("solid"),
crayon_body(", "),
crayon_key("dashed"),
crayon_body(", "),
crayon_key("dotted"),
crayon_body(", "),
crayon_key("dotdash"),
crayon_body(", "),
crayon_key("longdash"),
crayon_body(", "),
crayon_key("twodash"),
crayon_body(".")))
} else if (parameter_name == "direction.type"){
for (item in parameter){
assertthat::assert_that(item %in% c("diffHeight", "arrows"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("diffHeight"),
crayon_body(", "),
crayon_key("arrows"),
crayon_body(", "),
crayon_key("both"),
crayon_body(".")))
}
} else if (parameter_name == "self.link"){
assertthat::assert_that(parameter %in% c(1, 2),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("2"),
crayon_body(".")))
} else if (parameter_name == "directional"){
assertthat::assert_that(parameter %in% c(0, 1, 2, -1),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("0"),
crayon_body(", "),
crayon_key("1"),
crayon_body(", "),
crayon_key("2"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "link.arr.type"){
assertthat::assert_that(parameter %in% c("big.arrow", "triangle"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("big.arrow"),
crayon_body(", "),
crayon_key("triangle"),
crayon_body(".")))
} else if (parameter_name == "alignment"){
assertthat::assert_that(parameter %in% c("default", "vertical", "horizontal"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("vertical"),
crayon_body(", "),
crayon_key("horizontal"),
crayon_body(".")))
} else if (parameter_name == "alpha.highlight"){
assertthat::assert_that(parameter %in% c(seq(1, 99), "FF"),
msg = paste0(add_cross(), crayon_body("Please provide either "),
crayon_key("FF"),
crayon_body(" or a number between "),
crayon_key("1"),
crayon_body(" and "),
crayon_key("99"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "scale_type"){
assertthat::assert_that(parameter %in% c("categorical", "continuous"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("categorical"),
crayon_body(", "),
crayon_key("continuous"),
crayon_body(".")))
} else if (parameter_name == "axis.text.x.angle"){
assertthat::assert_that(parameter %in% c(0, 45, 90),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("0"),
crayon_body(", "),
crayon_key("45"),
crayon_body(", "),
crayon_key("90"),
crayon_body(".")))
} else if (parameter_name == "contour.lineend"){
assertthat::assert_that(parameter %in% c("round", "butt", "square"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("round"),
crayon_body(", "),
crayon_key("butt"),
crayon_body(", "),
crayon_key("square"),
crayon_body(".")))
} else if (parameter_name == "contour.linejoin"){
assertthat::assert_that(parameter %in% c("round", "mitre", "bevel"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("round"),
crayon_body(", "),
crayon_key("mitre"),
crayon_body(", "),
crayon_key("bevel"),
crayon_body(".")))
} else if (parameter_name == "contour.position"){
assertthat::assert_that(parameter %in% c("bottom", "top"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("top"),
crayon_body(", "),
crayon_key("bottom"),
crayon_body(".")))
} else if (parameter_name == "flavor"){
assertthat::assert_that(parameter %in% c("Seurat", "UCell"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("Seurat"),
crayon_body(", "),
crayon_key("UCell"),
crayon_body(".")))
} else if (parameter_name == "database"){
assertthat::assert_that(parameter %in% c("GO", "KEGG"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("GO"),
crayon_body(", "),
crayon_key("KEGG"),
crayon_body(".")))
} else if (parameter_name == "GO_ontology"){
assertthat::assert_that(parameter %in% c("BP", "MF", "CC"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("BP"),
crayon_body(", "),
crayon_key("MF"),
crayon_body(", "),
crayon_key("CC"),
crayon_body(".")))
} else if (parameter_name == "pAdjustMethod"){
assertthat::assert_that(parameter %in% c("holm", "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("holm"),
crayon_body(", "),
crayon_key("hochberg"),
crayon_body(", "),
crayon_key("bonferroni"),
crayon_body(", "),
crayon_key("BH"),
crayon_body(", "),
crayon_key("BY"),
crayon_body(", "),
crayon_key("fdr"),
crayon_body(", "),
crayon_key("none"),
crayon_body(".")))
} else if (parameter_name == "number.breaks"){
assertthat::assert_that(parameter >= 2,
msg = paste0(add_cross(), crayon_body("Please provide a value higher or equal to "),
crayon_key("2"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "border.density"){
assertthat::assert_that(parameter >= 0 & parameter <= 1,
msg = paste0(add_cross(), crayon_body("Please provide a value between "),
crayon_key("0"),
crayon_body(" and "),
crayon_key("1"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "diverging.palette"){
assertthat::assert_that(parameter %in% c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name == "sequential.palette"){
assertthat::assert_that(parameter %in% c("Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name %in% c("plot.title.face", "plot.subtitle.face", "plot.caption.face", "axis.title.face", "axis.text.face", "legend.title.face", "legend.text.face", "strip.text.face")){
assertthat::assert_that(parameter %in% c("plain", "italic", "bold", "bold.italic"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("plain", "italic", "bold", "bold.italic"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name %in% c("symmetry.type")){
assertthat::assert_that(parameter %in% c("absolute", "centered"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("absolute", "centered"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
}
}
#' Helper for do_AlluvialPlot.
#'
#' @param data Data to plot.
#' @param vars.use Names of the variables.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
prepare_ggplot_alluvial_plot <- function(data,
vars.use){
items <- length(vars.use)
`%>%` <- magrittr::`%>%`
assertthat::assert_that(items <= 10,
msg = paste0(add_cross(), crayon_body("Please provide, in between "),
crayon_key("first_group"),
crayon_body(", "),
crayon_key("middle_groups"),
crayon_body(" and "),
crayon_key("last_group"),
crayon_body(" only up to "),
crayon_key("ten"),
crayon_body("different unique elements.")))
if (items == 2){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]]))
} else if (items == 3){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]]))
} else if (items == 4){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]]))
} else if (items == 5){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]]))
} else if (items == 6){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]]))
} else if (items == 7){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]]))
} else if (items == 8) {
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]]))
} else if (items == 9){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]],
axis9 = data[[vars.use[9]]]))
} else if (items == 10){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]],
axis9 = data[[vars.use[9]]],
axis10 = data[[vars.use[10]]]))
}
return(p)
}
#' Helper for axis.text.x.angle.
#'
#' @param angle Angle of rotation.
#' @param flip Whether the plot if flipped or not.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_axis_parameters <- function(angle,
flip){
if (isTRUE(flip)){
if (angle == 0){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
} else if (angle == 45){
out <- list("angle" = angle,
"hjust" = 1,
"vjust" = 1)
} else if (angle == 90){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
}
} else if (base::isFALSE(flip)){
if (angle == 0){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0)
} else if (angle == 45){
out <- list("angle" = angle,
"hjust" = 1,
"vjust" = 1)
} else if (angle == 90){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
}
}
return(out)
}
#' Compute UMAP layers.
#'
#' @param sample TBD
#' @param labels TBD
#' @param pt.size TBD
#' @param dot.size TBD
#' @param alpha TBD
#' @param na.value TBD
#' @param border.density TBD
#' @param border.size TBD
#' @param border.color TBD
#' @param raster TBD
#' @param raster.dpi TBD
#' @param reduction TBD
#' @param group.by TBD
#' @param split.by TBD
#' @param n TBD
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_umap_layer <- function(sample,
labels,
pt.size,
dot.size = 7.5,
alpha = 1,
na.value = "grey75",
border.density = 1,
border.size,
border.color,
raster = FALSE,
raster.dpi = 1024,
reduction = "umap",
group.by = NULL,
split.by = NULL,
n = 100,
skip.density = FALSE) {
`%>%` <- magrittr::`%>%`
embeddings <- Seurat::Embeddings(sample,
reduction = reduction)[, labels, drop = FALSE] %>%
as.data.frame()
colnames(embeddings) <- c("x", "y")
# Code adapted from: https://slowkow.com/notes/ggplot2-color-by-density/
# Licensed under: CC BY-SA (compatible with GPL-3).
# Author: Kamil Slowikowski - https://slowkow.com/
# Obtain density.
if (base::isFALSE(skip.density)){
density <- MASS::kde2d(x = embeddings$x,
y = embeddings$y,
n = n)
# Find the intervals.
x.intervals <- findInterval(embeddings$x, density$x)
y.intervals <- findInterval(embeddings$y, density$y)
# Generate density vector to add to metadata.
interval_matrix <- cbind(x.intervals, y.intervals)
density_vector <- density$z[interval_matrix]
embeddings$density <- density_vector
}
# Add the group.by and split.by layers.
if (!is.null(group.by)){
embeddings <- embeddings %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::left_join(y = sample@meta.data %>%
dplyr::select(dplyr::all_of(c(group.by))) %>%
tibble::rownames_to_column(var = "cell"),
by = "cell") %>%
tibble::column_to_rownames(var = "cell")
colnames(embeddings) <- c(colnames(embeddings)[seq(1, (length(colnames(embeddings)) - 1))], "group.by")
if (base::isFALSE(skip.density)){
density.center.group.by <- embeddings %>%
dplyr::select(dplyr::all_of(c("x", "y", "group.by", "density"))) %>%
dplyr::group_by(.data$group.by) %>%
dplyr::mutate("filt_x_up" = stats::quantile(.data$x, 0.66),
"filt_x_down" = stats::quantile(.data$x, 0.33),
"filt_y_up" = stats::quantile(.data$y, 0.66),
"filt_y_down" = stats::quantile(.data$y, 0.33)) %>%
dplyr::filter(.data$x >= .data$filt_x_down & .data$x <= .data$filt_x_up,
.data$y >= .data$filt_y_down & .data$y <= .data$filt_y_up) %>%
dplyr::summarize("x" = mean(.data$x),
"y" = mean(.data$y))
}
}
if (!is.null(split.by)){
embeddings <- embeddings %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::left_join(y = sample@meta.data %>%
dplyr::select(dplyr::all_of(c(split.by))) %>%
tibble::rownames_to_column(var = "cell"),
by = "cell") %>%
tibble::column_to_rownames(var = "cell")
colnames(embeddings) <- c(colnames(embeddings)[seq(1, (length(colnames(embeddings)) - 1))], "split.by")
}
# Apply filtering criteria:
if (base::isFALSE(skip.density)){
embeddings <- embeddings %>%
dplyr::filter(.data$density <= stats::quantile(embeddings$density, border.density))
}
# Generate base layer.
if (base::isFALSE(raster)){
base_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
colour = border.color,
size = pt.size * border.size,
show.legend = FALSE,
na.rm = TRUE)
} else {
base_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = border.color,
size = pt.size * border.size,
stroke = pt.size / 2,
show.legend = FALSE,
pointsize = pt.size * border.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
# Generate NA layer.
if (base::isFALSE(raster)){
na_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
colour = na.value,
size = pt.size,
show.legend = FALSE,
na.rm = TRUE)
} else {
na_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = na.value,
size = pt.size,
stroke = pt.size / 2,
show.legend = FALSE,
pointsize = pt.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
# Generate center points layer.
out <- list()
if (!is.null(group.by) & base::isFALSE(skip.density)){
# Generate colored based layer.
if (base::isFALSE(raster)){
color_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
color = "white",
shape = 21,
alpha = alpha,
size = (pt.size * border.size) + 4,
stroke = 0,
show.legend = TRUE,
na.rm = TRUE)
} else {
color_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
size = (pt.size * border.size) + 4,
alpha = alpha,
stroke = pt.size / 2,
show.legend = TRUE,
pointsize = pt.size * border.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
out[["color_layer"]] <- color_layer
center_layer_2 <- ggplot2::geom_point(data = density.center.group.by,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = "black",
size = pt.size * dot.size)
center_layer <- ggplot2::geom_point(data = density.center.group.by,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
color = "white",
shape = 21,
size = pt.size * (dot.size - 2),
stroke = 1.5)
center_layers <- list("center_layer_2" = center_layer_2,
"center_layer_1" = center_layer)
out[["center_layers"]] <- center_layers
}
out[["base_layer"]] <- base_layer
out[["na_layer"]] <- na_layer
out[["embeddings"]] <- embeddings
return(out)
}
#
#
#' Duplicate secondary categorical axis.
#' From: https://github.com/tidyverse/ggplot2/issues/3171
#' @param label_trans Labels to send to the secondary axis.
#' @param ... Other
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
guide_axis_label_trans <- function(label_trans = identity, ...) {
axis_guide <- ggplot2::guide_axis(...)
axis_guide$label_trans <- rlang::as_function(label_trans)
class(axis_guide) <- c("guide_axis_trans", class(axis_guide))
axis_guide
}
#' Handle axis theme parameters
#'
#' @param flip TBD
#' @param counter TBD
#' @param group.by TBD
#' @param group TBD
#' @param xlab TBD
#' @param ylab TBD
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
handle_axis <- function(flip,
counter,
group.by,
group,
axis.text.x.angle,
plot.title.face,
plot.subtitle.face,
plot.caption.face,
axis.title.face,
axis.text.face,
legend.title.face,
legend.text.face){
# Set axis theme parameters.
if (base::isFALSE(flip)){
# Strips
if (counter == length(group.by)){
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_text(face = "bold", color = "black")
legend.position <- "none"
} else if (counter == 1) {
legend.position <- "bottom"
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
} else {
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
legend.position <- "none"
}
if (counter == 1){
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.ticks.y.left <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(face = axis.text.face, color = "black")
axis.text.y.left <- ggplot2::element_blank()
if (length(group.by) > 1){
axis.title.x.top <- ggplot2::element_blank()
axis.title.x.bottom <- ggplot2::element_blank()
} else {
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
vjust = 0.5,
hjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
}
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
hjust = 0.5,
vjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
} else {
axis.ticks.x.bottom <- ggplot2::element_blank()
axis.ticks.x.top <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.ticks.y.left <- ggplot2::element_blank()
axis.text.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(face = axis.text.face, color = "black")
axis.text.y.left <- ggplot2::element_blank()
if (length(group.by) > 1){
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
vjust = 0.5,
hjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
} else {
axis.title.x.top <- ggplot2::element_blank()
axis.title.x.bottom <- ggplot2::element_blank()
}
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
hjust = 0.5,
vjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
}
} else {
# Strips and legend.
if (counter == 1){
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_text(face = "bold", color = "black")
legend.position <- "none"
} else if (counter == length(group.by)){
legend.position <- "right"
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
} else {
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
legend.position <- "none"
}
if (counter == 1){
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
hjust = 0.5,
vjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
if (length(group.by) == 1){
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(color = "black", face = axis.text.face)
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
vjust = 0.5,
hjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
} else {
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_blank()
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
vjust = 0.5,
hjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
}
} else {
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
hjust = 0.5,
vjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
if (length(group.by) == counter){
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(color = "black", face = axis.text.face)
axis.title.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_blank()
} else {
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_blank()
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_blank()
axis.title.y.right <- ggplot2::element_blank()
}
}
}
out_list <- list("axis.ticks.x.top" = axis.ticks.x.top,
"axis.ticks.x.bottom" = axis.ticks.x.bottom,
"axis.ticks.y.left" = axis.ticks.y.left,
"axis.ticks.y.right" = axis.ticks.y.right,
"axis.text.x.bottom" = axis.text.x.bottom,
"axis.text.x.top" = axis.text.x.top,
"axis.text.y.left" = axis.text.y.left,
"axis.text.y.right" = axis.text.y.right,
"axis.title.x.bottom" = axis.title.x.bottom,
"axis.title.x.top" = axis.title.x.top,
"axis.title.y.left" = axis.title.y.left,
"axix.title.y.right" = axis.title.y.right,
"strip.background" = strip.background,
"strip.clip" = strip.clip,
"strip.text" = strip.text,
"legend.position" = legend.position)
return(out_list)
}
#' Generate a list of colors that will be used for metadata plots.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_SCpubr_colors <- function(){
colors <- c("#457b9d",
"#b5838d",
"#d4a276",
"#31572c",
"#354f52",
"#006d77",
"#bcb8b1",
"#d88c9a",
"#d8315b",
"#ee6c4d",
"#0c5460",
"#065a60",
"#d6ce93",
"#A88D21",
"#9a8c98",
"#6c757d",
"#00afb9",
"#38a3a5",
"#adc178",
"#bfd7b5")
return(colors)
}
#' Check the group.by parameter
#'
#' @param sample Seurat object.
#' @param group.by group.by parameter.
#' @param is.heatmap Whether the function computes a heatmap.
#'
#' @return The Seurat object.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_group_by <- function(sample,
group.by,
is.heatmap){
group.by.return <- NULL
if (is.null(group.by)){
assertthat::assert_that(!("Groups" %in% colnames(sample@meta.data)),
msg = paste0(add_cross(), crayon_body("Please, make sure you provide a value for "),
crayon_key("group.by"),
crayon_body(". The metadata column "),
crayon_key("Groups"),
crayon_body(" is used instead, but there is already such column in your metadata.")))
sample@meta.data[, "Groups"] <- sample@active.ident
group.by <- "Groups"
}
for (group in group.by){
assertthat::assert_that(group %in% colnames(sample@meta.data),
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(" is not part of the Seurat object "),
crayon_key("meta.data"),
crayon_body(".")))
assertthat::assert_that(class(sample@meta.data[, group]) %in% c("character", "factor"),
msg = paste0(add_cross(), crayon_body("The value provided to"),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(" is not a "),
crayon_key("character"),
crayon_body( "or "),
crayon_key("factor"),
crayon_body(" column in the sample"),
crayon_key("metadata of the Seurat object"),
crayon_body(".")))
if (isTRUE(is.heatmap)){
assertthat::assert_that(sum(is.na(sample@meta.data[, group])) == 0,
msg = paste0(add_warning(), crayon_body("Found "),
crayon_key("NAs"),
crayon_body(" in the metadata variable provided to "),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(". Please remove them before running the function.")))
}
group.by.return <- append(group.by.return, group)
}
return(list("sample" = sample,
"group.by" = group.by.return))
}
#' Temporal fix for DimPlots/FeaturePlots when using Assay5 and split.by
#'
#' @param sample Seurat object.
#' @param assay assay to use.
#'
#' @return The Seurat object.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_Assay5 <- function(sample,
assay = Seurat::DefaultAssay(sample)){
if (isTRUE(methods::is(sample@assays[[assay]], "Assay5"))){
suppressWarnings(sample@assays[[assay]] <- methods::as(sample@assays[[assay]], "Assay"))
}
return(sample)
}
#' Handles the generation of continuous color palettes for the plots.
#'
#' @param name Name of the palette.
#' @param use_viridis Whether it is a viridis palette or not.
#' @param direction Direction of the color scale.
#' @param enforce_symmetry Whether it is a diverging palette or not.
#'
#' @return The colors to use.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_continuous_palette <- function(name = "YlGnBu",
use_viridis = FALSE,
direction = ifelse(isTRUE(use_viridis), -1, 1),
enforce_symmetry = FALSE){
light_end <- "grey95"
dark_end <- "grey5"
if (base::isFALSE(enforce_symmetry)){
if (base::isFALSE(getOption("SCpubr.ColorPaletteEnds"))){
if (isTRUE(use_viridis)){
if (direction == 1){
colors <- c(viridis::viridis(n = 9, direction = direction, option = name))
} else if (direction == -1){
colors <- c(viridis::viridis(n = 9, direction = direction, option = name))
}
} else if (isFALSE(use_viridis)){
if (direction == 1){
colors <- c(RColorBrewer::brewer.pal(n = 9, name = name))
} else if (direction == -1){
colors <- c(rev(RColorBrewer::brewer.pal(n = 9, name = name)))
}
}
} else {
if (isTRUE(use_viridis)){
if (direction == 1){
colors <- c(dark_end, viridis::viridis(n = 9, direction = direction, option = name), light_end)
} else if (direction == -1){
colors <- c(light_end, viridis::viridis(n = 9, direction = direction, option = name), dark_end)
}
} else if (isFALSE(use_viridis)){
if (direction == 1){
colors <- c(light_end, RColorBrewer::brewer.pal(n = 9, name = name), dark_end)
} else if (direction == -1){
colors <- c(dark_end, rev(RColorBrewer::brewer.pal(n = 9, name = name)), light_end)
}
}
}
} else {
if (direction == 1){
colors <- RColorBrewer::brewer.pal(n = 11, name = name)
} else if (direction == -1){
colors <- rev(RColorBrewer::brewer.pal(n = 11, name = name))
}
}
return(colors)
}
#' Normalizes a continuous variable to comprise it between 0 to 1.
#'
#' @param x Continuous variable.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
zero_one_norm <- function(x){
y <- (x - min(x, na.rm = TRUE)) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))
return(y)
}
#' Normalizes a continuous variable to comprise it between -1 to 1.
#'
#' @param x Continuous variable.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
one_one_norm <- function(x){
y <- 2 * ((x - min(x, na.rm = TRUE)) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))) - 1
return(y)
}
#' Normalizes a continuous variable to comprise it between a to b.
#'
#' @param x Continuous variable.
#' @param a,b Ends of the range.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
range_norm <- function(x, a, b){
y <- (b - a) * ((x - (min(x, na.rm = TRUE))) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))) + a
return(y)
}
#' Rounds up a vector of percentages to ensure they add up to 100.
#'
#' First, truncates the values and keeps the truncated values and discarded decimals stored.
#' Then, it orders the discarded decimals and adds a unit to the correspondent truncated value
#' until the summ of truncated values reaches 100.
#'
#' For exclusive use in do_WafflePlot().
#'
#' @param x Data Frame of frequencies.
#' @param group.by The grouping variable used.
#'
#' @return A rounded up vector of percentages.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
round_percent <- function(x,
group.by){
# Generate named vector of freqs.
x <- as.data.frame(x)
names.use <- x[, group.by]
freqs <- x$freq
names(freqs) <- names.use
# Get trunctaed values and the removed percentages.
trimmed <- trunc(freqs)
cut.percent <- rev(sort(freqs - trimmed))
# Now, order the removed percentages and, in descending order, add a unit to the trimmed values until they add up to 100.
index <- 0
while(sum(trimmed) != 100){
index <- index + 1
trimmed[names(trimmed[index])] <- trimmed[index] + 1
}
# Return the new vector of rounded percentages.
return(trimmed)
}
enblacar/SCpubr documentation built on Aug. 25, 2024, 9:45 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions round_percent range_norm one_one_norm zero_one_norm compute_continuous_palette check_Assay5 check_group_by get_SCpubr_colors handle_axis guide_axis_label_trans compute_umap_layer get_axis_parameters prepare_ggplot_alluvial_plot check_parameters get_data_column_in_context get_data_column modify_continuous_legend compute_enrichment_scores modify_string add_scale check_length compute_factor_levels check_and_set_slot check_type check_and_set_assay check_and_set_dimensions check_and_set_reduction check_identity remove_duplicated_features remove_not_found_features check_feature check_limits compute_scales check_cutoffs compute_scale_limits generate_color_scale check_consistency_colors_and_names check_colors check_Seurat package_report check_suggests return_dependencies crayon_key add_tick add_warning add_cross add_info add_star crayon_body `%!in%` named_list named_vector doc_function
Documented in doc_function named_list named_vector package_report
#' Mock function used to document all main function.
#'
#' @param sample \strong{\code{\link[SeuratObject]{Seurat}}} | A Seurat object, generated by \link[Seurat]{CreateSeuratObject}.
#' @param font.size \strong{\code{\link[base]{numeric}}} | Overall font size of the plot. All plot elements will have a size relationship with this font size.
#' @param font.type \strong{\code{\link[base]{character}}} | Base font family for the plot. One of:
#' \itemize{
#' \item \emph{\code{mono}}: Mono spaced font.
#' \item \emph{\code{serif}}: Serif font family.
#' \item \emph{\code{sans}}: Default font family.
#' }
#' @param legend.type \strong{\code{\link[base]{character}}} | Type of legend to display. One of:
#' \itemize{
#' \item \emph{\code{normal}}: Default legend displayed by \pkg{ggplot2}.
#' \item \emph{\code{colorbar}}: Redefined colorbar legend, using \link[ggplot2]{guide_colorbar}.
#' }
#' @param legend.position \strong{\code{\link[base]{character}}} | Position of the legend in the plot. One of:
#' \itemize{
#' \item \emph{\code{top}}: Top of the figure.
#' \item \emph{\code{bottom}}: Bottom of the figure.
#' \item \emph{\code{left}}: Left of the figure.
#' \item \emph{\code{right}}: Right of the figure.
#' \item \emph{\code{none}}: No legend is displayed.
#' }
#' @param legend.title \strong{\code{\link[base]{character}}} | Title for the legend.
#' @param legend.title.position \strong{\code{\link[base]{character}}} | Position for the title of the legend. One of:
#' \itemize{
#' \item \emph{\code{top}}: Top of the legend.
#' \item \emph{\code{bottom}}: Bottom of the legend.
#' \item \emph{\code{left}}: Left of the legend.
#' \item \emph{\code{right}}: Right of the legend.
#' }
#' @param legend.framewidth,legend.tickwidth \strong{\code{\link[base]{numeric}}} | Width of the lines of the box in the legend.
#' @param legend.framecolor \strong{\code{\link[base]{character}}} | Color of the lines of the box in the legend.
#' @param legend.tickcolor \strong{\code{\link[base]{character}}} | Color of the ticks of the box in the legend.
#' @param legend.length,legend.width \strong{\code{\link[base]{numeric}}} | Length and width of the legend. Will adjust automatically depending on legend side.
#' @param legend.icon.size \strong{\code{\link[base]{numeric}}} | Size of the icons in legend.
#' @param legend.ncol \strong{\code{\link[base]{numeric}}} | Number of columns in the legend.
#' @param legend.nrow \strong{\code{\link[base]{numeric}}} | Number of rows in the legend.
#' @param legend.byrow \strong{\code{\link[base]{logical}}} | Whether the legend is filled by row or not.
#' @param plot.title,plot.subtitle,plot.caption \strong{\code{\link[base]{character}}} | Title, subtitle or caption to use in the plot.
#' @param individual.titles,individual.subtitles,individual.captions \strong{\code{\link[base]{character}}} | Vector. Title, subtitle or caption to use in the plot when multiple features are passed on. Use NA to keep the original title.
#' @param reduction \strong{\code{\link[base]{character}}} | Reduction to use. Can be the canonical ones such as "umap", "pca", or any custom ones, such as "diffusion". If you are unsure about which reductions you have, use `Seurat::Reductions(sample)`. Defaults to "umap" if present or to the last computed reduction if the argument is not provided.
#' @param assay \strong{\code{\link[base]{character}}} | Assay to use. Defaults to the current assay.
#' @param slot \strong{\code{\link[base]{character}}} | Data slot to use. Only one of: counts, data, scale.data. Defaults to "data".
#' @param viridis.palette \strong{\code{\link[base]{character}}} | A capital letter from A to H or the scale name as in \link[viridis]{scale_fill_viridis}.
#' @param viridis.palette.pvalue,viridis.palette.logfc,viridis.palette.expression \strong{\code{\link[base]{character}}} | Viridis color palettes for the p-value, logfc and expression heatmaps. A capital letter from A to H or the scale name as in \link[viridis]{scale_fill_viridis}.
#' @param raster \strong{\code{\link[base]{logical}}} | Whether to raster the resulting plot. This is recommendable if plotting a lot of cells.
#' @param raster.dpi \strong{\code{\link[base]{numeric}}} | Pixel resolution for rasterized plots. Defaults to 1024. Only activates on Seurat versions higher or equal than 4.1.0.
#' @param plot_cell_borders \strong{\code{\link[base]{logical}}} | Whether to plot border around cells.
#' @param border.size \strong{\code{\link[base]{numeric}}} | Width of the border of the cells.
#' @param border.color \strong{\code{\link[base]{character}}} | Color for the border of the heatmap body.
#' @param na.value \strong{\code{\link[base]{character}}} | Color value for NA.
#' @param axis.text.x.angle \strong{\code{\link[base]{numeric}}} | Degree to rotate the X labels. One of: 0, 45, 90.
#' @param xlab,ylab \strong{\code{\link[base]{character}}} | Titles for the X and Y axis.
#' @param pt.size \strong{\code{\link[base]{numeric}}} | Size of the dots.
#' @param flip \strong{\code{\link[base]{logical}}} | Whether to invert the axis of the displayed plot.
#' @param verbose \strong{\code{\link[base]{logical}}} | Whether to show extra comments, warnings,etc.
#' @param group.by \strong{\code{\link[base]{character}}} | Metadata variable to group the output by. Has to be a character of factor column.
#' @param split.by \strong{\code{\link[base]{character}}} | Secondary metadata variable to further group (split) the output by. Has to be a character of factor column.
#' @param colors.use \strong{\code{\link[SCpubr]{named_vector}}} | Named vector of valid color representations (either name of HEX codes) with as many named colors as unique values of group.by. If group.by is not provided, defaults to the unique values of \link[Seurat]{Idents}. If not provided, a color scale will be set by default.
#' @param plot_marginal_distributions \strong{\code{\link[base]{logical}}} | Whether to plot marginal distributions on the figure or not.
#' @param marginal.type \strong{\code{\link[base]{character}}} | One of:
#' \itemize{
#' \item \emph{\code{density}}: Compute density plots on the margins.
#' \item \emph{\code{histogram}}: Compute histograms on the margins.
#' \item \emph{\code{boxplot}}: Compute boxplot on the margins.
#' \item \emph{\code{violin}}: Compute violin plots on the margins.
#' \item \emph{\code{densigram}}: Compute densigram plots on the margins.
#' }
#' @param marginal.size \strong{\code{\link[base]{numeric}}} | Size ratio between the main and marginal plots. A value of 5 means that the main plot is 5 times bigger than the marginal plots.
#' @param marginal.group \strong{\code{\link[base]{logical}}} | Whether to group the marginal distribution by group.by or current identities.
#' @param enforce_symmetry \strong{\code{\link[base]{logical}}} | Return a symmetrical plot axes-wise or continuous color scale-wise, when applicable.
#' @param column_title \strong{\code{\link[base]{character}}} | Title for the columns of the heatmaps. Only works with single heatmaps.
#' @param row_title \strong{\code{\link[base]{character}}} | Title for the rows of the heatmaps. Only works with single heatmaps.
#' @param cluster_cols \strong{\code{\link[base]{logical}}} | Cluster the columns or rows of the heatmaps.
#' @param cluster_rows \strong{\code{\link[base]{logical}}} | Cluster the rows or rows of the heatmaps.
#' @param column_names_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the column labels.
#' @param row_names_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the row labels.
#' @param cell_size \strong{\code{\link[base]{numeric}}} | Size of each cell in the heatmap.
#' @param input_gene_list \strong{\code{\link[SCpubr]{named_list}}} | Named list of lists of genes to be used as input.
#' @param column_title_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the column titles.
#' @param row_title_rot \strong{\code{\link[base]{numeric}}} | Degree in which to rotate the row titles.
#' @param column_names_side \strong{\code{\link[base]{character}}} | Side to put the column names. Either left or right.
#' @param row_names_side \strong{\code{\link[base]{character}}} | Side to put the row names. Either left or right.
#' @param column_title_side \strong{\code{\link[base]{character}}} | Side to put the column titles Either left or right.
#' @param row_title_side \strong{\code{\link[base]{character}}} | Side to put the row titles Either left or right.
#' @param heatmap.legend.length,heatmap.legend.width \strong{\code{\link[base]{numeric}}} | Width and length of the legend in the heatmap.
#' @param heatmap.legend.framecolor \strong{\code{\link[base]{character}}} | Color of the edges and ticks of the legend in the heatmap.
#' @param scale_direction \strong{\code{\link[base]{numeric}}} | Direction of the viridis scales. Either -1 or 1.
#' @param heatmap_gap \strong{\code{\link[base]{numeric}}} | Gap in cm between heatmaps.
#' @param legend_gap \strong{\code{\link[base]{numeric}}} | Gap in cm between legends.
#' @param cells.highlight,idents.highlight \strong{\code{\link[base]{character}}} | Vector of cells/identities to focus into. The identities have to much those in \code{Seurat::Idents(sample)} The rest of the cells will be grayed out. Both parameters can be used at the same time.
#' @param dims \strong{\code{\link[base]{numeric}}} | Vector of 2 numerics indicating the dimensions to plot out of the selected reduction. Defaults to c(1, 2) if not specified.
#' @param ncol \strong{\code{\link[base]{numeric}}} | Number of columns used in the arrangement of the output plot using "split.by" parameter.
#' @param features \strong{\code{\link[base]{character}}} | Features to represent.
#' @param feature \strong{\code{\link[base]{character}}} | Feature to represent.
#' @param use_viridis \strong{\code{\link[base]{logical}}} | Whether to use viridis color scales.
#' @param viridis.direction \strong{\code{\link[base]{numeric}}} | Either 1 or -1. Controls how the gradient of viridis scale is formed.
#' @param plot.grid \strong{\code{\link[base]{logical}}} | Whether to plot grid lines.
#' @param grid.color \strong{\code{\link[base]{character}}} | Color of the grid in the plot. In heatmaps, color of the border of the cells.
#' @param grid.type \strong{\code{\link[base]{character}}} | One of the possible linetype options:
#' \itemize{
#' \item \emph{\code{blank}}.
#' \item \emph{\code{solid}}.
#' \item \emph{\code{dashed}}.
#' \item \emph{\code{dotted}}.
#' \item \emph{\code{dotdash}}.
#' \item \emph{\code{longdash}}.
#' \item \emph{\code{twodash}}.
#' }
#' @param plot.axes \strong{\code{\link[base]{logical}}} | Whether to plot axes or not.
#' @param nbin \strong{\code{\link[base]{numeric}}} | Number of bins to use in \link[Seurat]{AddModuleScore}.
#' @param ctrl \strong{\code{\link[base]{numeric}}} | Number of genes in the control set to use in \link[Seurat]{AddModuleScore}.
#' @param repel \strong{\code{\link[base]{logical}}} | Whether to repel the text labels.
#' @param plot_density_contour \strong{\code{\link[base]{logical}}} | Whether to plot density contours in the UMAP.
#' @param contour.position \strong{\code{\link[base]{character}}} | Whether to plot density contours on top or at the bottom of the visualization layers, thus overlapping the clusters/cells or not.
#' @param contour.color \strong{\code{\link[base]{character}}} | Color of the density lines.
#' @param contour.lineend \strong{\code{\link[base]{character}}} | Line end style (round, butt, square).
#' @param contour.linejoin \strong{\code{\link[base]{character}}} | Line join style (round, mitre, bevel).
#' @param contour_expand_axes \strong{\code{\link[base]{numeric}}} | To make the contours fit the plot, the limits of the X and Y axis are expanding a given percentage from the min and max values for each axis. This controls such percentage.
#' @param min.cutoff,max.cutoff \strong{\code{\link[base]{numeric}}} | Set the min/max ends of the color scale. Any cell/group with a value lower than min.cutoff will turn into min.cutoff and any cell with a value higher than max.cutoff will turn into max.cutoff. In FeaturePlots, provide as many values as features. Use NAs to skip a feature.
#' @param label \strong{\code{\link[base]{logical}}} | Whether to plot the cluster labels in the UMAP. The cluster labels will have the same color as the cluster colors.
#' @param label.color \strong{\code{\link[base]{character}}} | Color of the labels in the plot.
#' @param label.fill \strong{\code{\link[base]{character}}} | Color to fill the labels. Has to be a single color, that will be used for all labels. If \strong{\code{NULL}}, the colors of the clusters will be used instead.
#' @param label.size \strong{\code{\link[base]{numeric}}} | Size of the labels in the plot.
#' @param label.box \strong{\code{\link[base]{logical}}} | Whether to plot the plot labels as \strong{\code{\link[ggplot2]{geom_text}}} (FALSE) or \strong{\code{\link[ggplot2]{geom_label}}} (TRUE).
#' @param min.overlap \strong{\code{\link[base]{numeric}}} | Filter the output result to the terms which are supported by this many genes.
#' @param GO_ontology \strong{\code{\link[base]{character}}} | GO ontology to use. One of:
#' \itemize{
#' \item \emph{\code{BP}}: For \strong{B}iological \strong{P}rocess.
#' \item \emph{\code{MF}}: For \strong{M}olecular \strong{F}unction.
#' \item \emph{\code{CC}}: For \strong{C}ellular \strong{C}omponent.
#' }
#' @param genes \strong{\code{\link[base]{character}}} | Vector of gene symbols to query for functional annotation.
#' @param org.db \strong{\code{OrgDB}} | Database object to use for the query.
#' @param disable_white_in_viridis \strong{\code{\link[base]{logical}}} | Remove the white in viridis color scale when \strong{\code{viridis.direction}} is set to -1.
#' @param number.breaks \strong{\code{\link[base]{numeric}}} | Controls the number of breaks in continuous color scales of ggplot2-based plots.
#' @param border.density \strong{\code{\link[base]{numeric}}} | Controls the number of cells used when \strong{\code{plot_cell_borders = TRUE}}. Value between 0 and 1. It computes a 2D kernel density and based on this cells that have a density below the specified quantile will be used to generate the cluster contour. The lower this number, the less cells will be selected, thus reducing the overall size of the plot but also potentially preventing all the contours to be properly drawn.
#' @param strip.spacing \strong{\code{\link[base]{numeric}}} | Controls the size between the different facets.
#' @param strip.text.color \strong{\code{\link[base]{character}}} | Color of the strip text.
#' @param strip.text.angle \strong{\code{\link[base]{numeric}}} | Rotation of the strip text (angles).
#' @param diverging.palette \strong{\code{\link[base]{character}}} | Type of symmetrical color palette to use. Out of the diverging palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param diverging.direction \strong{\code{\link[base]{numeric}}} | Either 1 or -1. Direction of the divering palette. This basically flips the two ends.
#' @param sequential.palette \strong{\code{\link[base]{character}}} | Type of sequential color palette to use. Out of the sequential palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param sequential.palette.pvalue,sequential.palette.expression,sequential.palette.logfc \strong{\code{\link[base]{character}}} | Sequential palettes for p-value, logfc and expression heatmaps. Type of sequential color palette to use. Out of the sequential palettes defined in \strong{\code{\link[RColorBrewer]{brewer.pal}}}.
#' @param sequential.direction \strong{\code{\link[base]{numeric}}} | Direction of the sequential color scale. Either 1 or -1.
#' @param return_object \strong{\code{\link[base]{logical}}} | Returns the Seurat object with the modifications performed in the function. Nomally, this contains a new assay with the data that can then be used for any other visualization desired.
#' @param statistic \strong{\code{\link[base]{character}}} | DecoupleR statistic to use. One of:
#' \itemize{
#' \item \emph{\code{wmean}}: For weighted mean.
#' \item \emph{\code{norm_wmean}}: For normalized weighted mean.
#' \item \emph{\code{corr_wmean}}: For corrected weighted mean.
#' }
#' @param subsample \strong{\code{\link[base]{numeric}}} | Number of cells to randomly select from the Seurat object to enhance performance. Selecting NA will disable this but might lead to function breaks if the sample size is too large.
#' @param cluster \strong{\code{\link[base]{logical}}} | Whether to perform clustering of rows and columns.
#' @param subsample \strong{\code{\link[base]{numeric}}} | Number of cells to subset for the analysis. NA will use all. Cells are selected at random.
#' @param plot.title.face,plot.subtitle.face,plot.caption.face,axis.title.face,axis.text.face,legend.title.face,legend.text.face \strong{\code{\link[base]{character}}} | Controls the style of the font for the corresponding theme element. One of:
#' \itemize{
#' \item \emph{\code{plain}}: For normal text.
#' \item \emph{\code{italic}}: For text in itallic.
#' \item \emph{\code{bold}}: For text in bold.
#' \item \emph{\code{bold.italic}}: For text both in itallic and bold.
#' }
#' @param strip.text.face \strong{\code{\link[base]{character}}} | Controls the style of the font for the strip text. One of:
#' \itemize{
#' \item \emph{\code{plain}}: For normal text.
#' \item \emph{\code{italic}}: For text in itallic.
#' \item \emph{\code{bold}}: For text in bold.
#' \item \emph{\code{bold.italic}}: For text both in itallic and bold.
#' }
#' @param flavor \strong{\code{\link[base]{character}}} | One of: Seurat, UCell. Compute the enrichment scores using \link[Seurat]{AddModuleScore} or \link[UCell]{AddModuleScore_UCell}.
#' @param features.order \strong{\code{\link[base]{character}}} | Should the gene sets be ordered in a specific way? Provide it as a vector of characters with the same names as the names of the gene sets.
#' @param groups.order \strong{\code{\link[SCpubr]{named_list}}} | Should the groups in theheatmaps be ordered in a specific way? Provide it as a named list (as many lists as values in \strong{\code{group.by}}) with the order for each of the elements in the groups.
#' @param interpolate \strong{\code{\link[base]{logical}}} | Smoothes the output heatmap, saving space on disk when saving the image. However, the image is not as crisp.
#' @param order \strong{\code{\link[base]{logical}}} | Whether to order the boxplots by average values. Can not be used alongside split.by.
#' @param dot.scale \strong{\code{\link[base]{numeric}}} | Scale the size of the dots.
#' @usage NULL
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @examples
#'
#' # This a mock function that stores the documentation for many other functions.
#' # It is not intended for user usage.
doc_function <- function(sample,
font.size,
font.type,
legend.type,
legend.position,
legend.framewidth,
legend.tickwidth,
legend.framecolor,
legend.tickcolor,
legend.length,
legend.width,
plot.title,
plot.subtitle,
plot.caption,
assay,
slot,
reduction,
viridis.palette,
raster,
raster.dpi,
plot_cell_borders,
border.size,
border.color,
na.value,
axis.text.x.angle,
xlab,
ylab,
pt.size,
verbose,
flip,
group.by,
split.by,
colors.use,
legend.title,
legend.icon.size,
legend.byrow,
legend.ncol,
legend.nrow,
plot_marginal_distributions,
marginal.type,
marginal.size,
marginal.group,
enforce_symmetry,
column_title,
row_title,
cluster_cols,
cluster_rows,
column_names_rot,
row_names_rot,
cell_size,
input_gene_list,
column_title_rot,
row_title_rot,
column_names_side,
row_names_side,
column_title_side,
row_title_side,
heatmap.legend.length,
heatmap.legend.width,
heatmap.legend.framecolor,
scale_direction,
heatmap_gap,
legend_gap,
cells.highlight,
idents.highlight,
ncol,
dims,
feature,
features,
use_viridis,
viridis.direction,
plot.grid,
grid.color,
grid.type,
plot.axes,
individual.titles,
individual.subtitles,
individual.captions,
legend.title.position,
repel,
plot_density_contour,
contour.position,
contour.color,
contour.lineend,
contour.linejoin,
contour_expand_axes,
label,
label.color,
label.fill,
label.size,
label.box,
min.overlap,
GO_ontology,
genes,
org.db,
disable_white_in_viridis,
number.breaks,
strip.spacing,
strip.text.color,
strip.text.angle,
diverging.palette,
diverging.direction,
subsample,
plot.title.face,
plot.subtitle.face,
plot.caption.face,
axis.title.face,
axis.text.face,
legend.title.face,
legend.text.face,
flavor,
features.order,
groups.order,
interpolate,
order,
dot.scale){}
#' Named vector.
#'
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @usage NULL
#' @examples
#' # This is a named vector.
#' x <- c("first_element" = 3,
#' "second_element" = TRUE)
#' print(x)
#'
named_vector <- function(){}
#' Named list.
#'
#' @return Nothing. This is a mock function.
#' @keywords internal
#' @usage NULL
#' @examples
#' # This is a named vector.
#' x <- list("first_element" = c("GENE A", "GENE B"),
#' "second_element" = c("GENE C", "GENE D"))
#' print(x)
#'
named_list <- function(){}
# Operators.
# Not in operator.
`%!in%` <- function(x, y) {return(!(x %in% y))}
# nocov start
crayon_body <- function(text){
return(cli::col_none(text))
}
add_star <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_yellow(cli::style_bold(cli::symbol$star)), " "))
} else {
return("* ")
}
}
add_info <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_cyan(cli::style_bold(cli::symbol$info)), " "))
} else {
return("i ")
}
}
add_cross <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_red(cli::style_bold(cli::symbol$cross)), " "))
} else {
return("x ")
}
}
add_warning <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n", ""), cli::col_yellow(cli::style_bold("!")), " "))
} else {
return("! ")
}
}
add_tick <- function(initial_newline = TRUE){
if (isTRUE(requireNamespace("cli", quietly = TRUE))){
return(paste0(ifelse(isTRUE(initial_newline), "\n\n", ""), cli::col_green(cli::style_bold(cli::symbol$tick)), " "))
} else {
return("")
}
}
crayon_key <- function(text){
return(cli::col_cyan(text))
}
# nocov end
#' Return a list of SCpubr dependencies.
#'
#' @noRd
#' @return None
#' @examples
#' \donttest{
#' TBD
#' }
return_dependencies <- function(){
pkg_list <- list("Essentials" = c("Seurat",
"SeuratObject",
"rlang",
"dplyr",
"magrittr",
"dplyr",
"tidyr",
"tibble",
"stringr",
"ggplot2",
"patchwork",
"plyr",
"viridis",
"forcats",
"scales",
"assertthat",
"RColorBrewer",
"labeling",
"withr"),
"do_AffinityAnalysisPlot" = "decoupleR",
"do_AlluvialPlot" = "ggalluvial",
"do_BarPlot" = c("colorspace", "ggrepel"),
"do_BeeSwarmPlot" = c("colorspace", "ggbeeswarm", "ggrastr"),
"do_BoxPlot" = "ggsignif",
"do_CellularStatesPlot" = c("pbapply", "ggExtra", "ggplotify", "scattermore"),
"do_ChordDiagramPlot" = "circlize",
"do_ColorPalette" = NULL,
"do_CopyNumberVariantPlot" = "ggdist",
"do_CorrelationPlot" = NULL,
"do_DimPlot" = c("colorspace", "ggplotify", "scattermore"),
"do_DotPlot" = NULL,
"do_EnrichmentHeatmap" = c("UCell"),
"do_ExpressionHeatmap" = NULL,
"do_FeaturePlot" = c("scattermore", "MASS"),
"do_GeyserPlot" = "ggdist",
"do_GroupwiseDEPlot" = NULL,
"do_MetadataPlot" = "cluster",
"do_LigandReceptorPlot" = "liana",
"do_LoadingsPlot" = NULL,
"do_RankedEnrichmentPlot" = "Matrix",
"do_RankedExpressionPlot" = NULL,
"do_NebulosaPlot" = "Nebulosa",
"do_PathwayActivityPlot" = NULL,
"do_RidgePlot" = "ggridges",
"do_SCExpressionHeatmap" = NULL,
"do_SCEnrichmentHeatmap" = c("UCell"),
"do_TermEnrichmentPlot" = c("enrichplot"),
"do_TFActivityPlot" = NULL,
"do_ViolinPlot" = NULL,
"do_VolcanoPlot" = "ggrepel",
"do_WafflePlot" = "waffle",
"save_Plot" = "svglite")
return(pkg_list)
}
#' Checks for Suggests.
#'
#' @noRd
#' @return None
#' @examples
#' \donttest{
#' TBD
#' }
check_suggests <- function(function_name, passive = FALSE){
pkg_list <- return_dependencies()
# The function is not in the current list of possibilities.
if (function_name %!in% names(pkg_list)){
stop(paste0(add_cross(), crayon_key(function_name), crayon_body(" is not an accepted function name.")), call. = FALSE)
}
pkgs <- c(pkg_list[[function_name]], pkg_list[["Essentials"]])
non_seurat_functions <- c("save_Plot",
"do_VolcanoPlot",
"do_LigandReceptorPlot",
"do_ColorPalette")
if (function_name %in% non_seurat_functions){
pkgs <- pkgs[!(pkgs %in% c("Seurat", "SeuratObject"))]
}
pkgs <- vapply(pkgs, requireNamespace, quietly = TRUE, FUN.VALUE = logical(1))
# nocov start
if(sum(!pkgs) > 0){
missing_pkgs <- names(pkgs[vapply(pkgs, function(x){base::isFALSE(x)}, FUN.VALUE = logical(1))])
if (base::isFALSE(passive)){
stop(paste0(add_cross(), crayon_body("Packages "),
paste(vapply(missing_pkgs, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(" must be installed to use "),
crayon_key(function_name),
crayon_body(".")), call. = FALSE)
}
}
value <- if(sum(pkgs) != length(pkgs)){FALSE} else {TRUE}
if (isTRUE(passive)) {return(value)}
# nocov end
}
#' Generate a status report of SCpubr and its dependencies.
#'
#' This function generates a summary report of the installation status of SCpubr, which packages are still missing and which functions can or can not currently be used.
#'
#' @param startup \strong{\code{\link[base]{logical}}} | Whether the message should be displayed at startup, therefore, also containing welcoming messages and tips. If \strong{\code{FALSE}}, only the report itself will be printed.
#' @param extended \strong{\code{\link[base]{logical}}} | Whether the message should also include installed packages, current and available version, and which \strong{\code{SCpubr}} functions can be used with the currently installed packages.
#' @return None
#' @export
#'
#' @examples
#'
#' \donttest{
#' # Print a package report.
#' SCpubr::package_report(startup = FALSE, extended = FALSE)
#' }
package_report <- function(startup = FALSE,
extended = FALSE){
# nocov start
if (base::isFALSE(requireNamespace("cli", quietly = TRUE)) | base::isFALSE(requireNamespace("rlang", quietly = TRUE))){
if (base::isFALSE(startup)){
message(paste(rep("-", 63), collapse = ""))
message('This is a placeholder message. Please install "cli" and "rlang" packages to have an optimal experience using the package.')
message(paste(rep("-", 63), collapse = ""))
} else if(isTRUE(startup)){
packageStartupMessage(paste(rep("-", 63), collapse = ""))
packageStartupMessage('This is a placeholder message. Please install "cli" and "rlang" packages to have an optimal experience using the package.')
packageStartupMessage(paste(rep("-", 63), collapse = ""))
packageStartupMessage("\n\n\nSCpubr")
packageStartupMessage("\nIf you use SCpubr in your research, please cite it accordingly: \nBlanco-Carmona, E. Generating publication ready visualizations for Single Cell transcriptomics using SCpubr. bioRxiv (2022) doi:10.1101/2022.02.28.482303.\n")
packageStartupMessage("If the package is useful to you, consider leaving a Star in the GitHub repo: https://github.com/enblacar/SCpubr/stargazers \n")
packageStartupMessage("Keep track of the package updates on Twitter (@Enblacar) or in https://github.com/enblacar/SCpubr/blob/main/NEWS.md \n")
packageStartupMessage("To suppress this startup message, use: \nsuppressPackageStartupMessages(library('SCpubr'))")
packageStartupMessage(paste(rep("-", 63), collapse = ""))
}
} else {
# nocov end
tip_rule <- cli::rule(left = "General", width = nchar("General") + 6)
tutorials <- paste0(add_info(initial_newline = FALSE),
crayon_body("Have a look at extensive tutorials in "),
crayon_key(cli::style_hyperlink(text = "SCpubr's book",
url = "https://enblacar.github.io/SCpubr-book/")),
crayon_body("."))
cite <- paste0(add_tick(initial_newline = FALSE),
crayon_body("If you use "),
crayon_key("SCpubr"),
crayon_body(" in your research, please "),
crayon_key(cli::style_hyperlink(text = "cite it accordingly",
url = "https://www.biorxiv.org/content/10.1101/2022.02.28.482303v1")),
crayon_body("."))
stars <- paste0(add_star(initial_newline = FALSE),
crayon_body("If the package is useful to you, consider leaving a "),
crayon_key("Star"),
crayon_body(" in the "),
crayon_key(cli::style_hyperlink(text = "GitHub repository",
url = "https://github.com/enblacar/SCpubr")),
crayon_body("."))
updates <- paste0(cli::style_bold(cli::col_blue("!")),
crayon_body(" Keep track of the package "),
crayon_key("updates"),
crayon_body(" on Twitter ("),
crayon_key(cli::style_hyperlink(text = "@Enblacar",
url = "https://twitter.com/Enblacar")),
crayon_body(") or in the "),
crayon_key(cli::style_hyperlink(text = "Official NEWS website",
url = "https://github.com/enblacar/SCpubr/blob/main/NEWS.md")),
crayon_body("."))
plotting <- paste0(cli::style_bold(cli::col_red(cli::symbol$heart)), " ", crayon_body("Happy plotting!"))
header <- cli::rule(left = paste0(crayon_body("SCpubr "),
crayon_key(utils::packageVersion("SCpubr"))), line_col = "cadetblue")
if (isTRUE(extended)){
format_package_name <- function(package,
max_length_packages){
length.use <- max_length_packages - nchar(package)
package.use <- paste0(package, paste(rep(" ", length.use), collapse = ""))
if (isTRUE(requireNamespace(package, quietly = TRUE))){
if ((package == "ggplot2") & (utils::packageVersion(package) < "3.4.0")){
name <- paste0(cli::col_yellow(cli::style_bold("!")),
" ",
cli::col_magenta(package.use))
} else if ((package == "dplyr") & (utils::packageVersion(package) < "1.1.0")){
name <- paste0(cli::col_yellow(cli::style_bold("!")),
" ",
cli::col_magenta(package.use))
} else {
name <- paste0(cli::col_green(cli::symbol$tick),
crayon_body(" "),
crayon_body(package.use))
}
return(name)
} else {
return(paste0(cli::col_red(cli::symbol$cross),
crayon_body(" "),
cli::col_red(package.use)))
}
}
packages <- sort(unique(unlist(return_dependencies())))
max_length_packages <- max(vapply(packages, nchar, FUN.VALUE = numeric(1)))
packages_mod <- vapply(packages, function(x){format_package_name(x,
max_length_packages = max_length_packages)}, FUN.VALUE = character(1))
functions <- sort(unique(names(return_dependencies())))
if (rev(strsplit(as.character( as.character(utils::packageVersion("SCpubr"))), split = "\\.")[[1]])[1] >= 9000){
names.use <- unname(vapply(functions, function(x){if (x %in% c("do_LigandReceptorPlot",
"save_Plot",
"do_MetadataPlot",
"do_SCExpressionHeatmap",
"do_SCEnrichmentHeatmap",
"do_AffinityAnalysisPlot",
"do_DiffusionMapPlot",
"do_LoadingsPlot")){x <- paste0(x, cli::col_cyan(" | DEV"))} else {x}}, FUN.VALUE = character(1)))
functions <- vapply(functions, check_suggests, passive = TRUE, FUN.VALUE = logical(1))
names(functions) <- names.use
# nocov start
} else {
functions <- functions[!(functions %in% c("do_LigandReceptorPlot",
"save_Plot",
"do_MetadataPlot",
"do_SCExpressionHeatmap",
"do_SCEnrichmentHeatmap",
"do_AffinityAnalysisPlot",
"do_DiffusionMapPlot",
"do_LoadingsPlot"))]
functions <- vapply(functions, check_suggests, passive = TRUE, FUN.VALUE = logical(1))
}
# nocov end
functions <- functions[names(functions) != "Essentials"]
max_length_functions <- max(vapply(names(functions), nchar, FUN.VALUE = numeric(1)))
format_functions <- function(name, value, max_length){
func_use <- ifelse(isTRUE(value), cli::col_green(cli::symbol$tick), cli::col_red(cli::symbol$cross))
name_use <- ifelse(isTRUE(value),
cli::ansi_align(crayon_body(name), max_length, align = "left"),
cli::ansi_align(cli::col_red(name), max_length, align = "left"))
paste0(func_use, " ", name_use)
}
functions.use <- NULL
for(item in names(functions)){
functions.use <- append(functions.use, format_functions(name = item, value = functions[[item]], max_length = max_length_functions))
}
counter <- 0
print.list <- list()
print.list.functions <- list()
print.vector <- NULL
print.vector.functions <- NULL
for(item in packages_mod){
counter <- counter + 1
if (counter %% 4 != 0){
print.vector <- append(print.vector, item)
if (counter == length(packages)){
print.list[[item]] <- paste(print.vector, collapse = " ")
print.vector <- NULL
}
} else {
print.vector <- append(print.vector, item)
print.list[[item]] <- paste(print.vector, collapse = " ")
print.vector <- NULL
}
}
counter <- 0
for(item in functions.use){
counter <- counter + 1
if (counter %% 3 != 0){
print.vector.functions <- append(print.vector.functions, item)
if (counter == length(functions.use)){
print.list.functions[[item]] <- paste(print.vector.functions, collapse = " ")
}
} else {
print.vector.functions <- append(print.vector.functions, item)
print.list.functions[[item]] <- paste(print.vector.functions, collapse = " ")
print.vector.functions <- NULL
}
}
packages_check <- cli::rule(left = "Required packages", width = nchar("Required packages") + 6)
packages_tip1 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Installed packages are denoted by a "),
crayon_key("tick"),
crayon_body(" ("),
cli::style_bold(cli::col_green(cli::symbol$tick)),
crayon_body(") and missing packages by a "),
cli::col_red("cross"),
crayon_body(" ("),
cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(")."))
packages_tip2 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Installed packages that still require an update to correctly run "),
crayon_key("SCpubr"),
crayon_body(" have an "),
crayon_key("exclamation mark"),
crayon_body(" ("),
cli::style_bold(cli::col_yellow("!")),
crayon_body(")."))
functions_check <- cli::rule(left = "Available functions", width = nchar("Available functions") + 6)
functions_tip1 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" Functions tied to "),
crayon_key("development"),
crayon_body(" builds of "),
crayon_key("SCpubr"),
crayon_body(" are marked by the ("),
cli::style_bold(cli::col_cyan("| DEV")),
crayon_body(") tag."))
functions_tip2 <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" You can install development builds of "),
crayon_key("SCpubr"),
crayon_body(" by following the instructions in the "),
crayon_key(cli::style_hyperlink(text = "Releases",
url = "https://github.com/enblacar/SCpubr/releases")),
crayon_body(" page."))
}
tip_rule <- cli::rule(left = "Tips!", width = nchar("Tips!") + 6)
ins_message <- paste0(cli::style_bold(cli::col_blue("!")),
crayon_body(" Check missing dependencies with: "),
cli::style_italic(crayon_key('SCpubr::package_report(extended = TRUE)')))
tip_message <- paste0(cli::style_bold(cli::col_cyan(cli::symbol$info)),
crayon_body(" To remove the white and black end from continuous palettes, use: "),
cli::style_italic(crayon_key('options("SCpubr.ColorPaletteEnds" = FALSE)')))
disable_message <- paste0(cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(" To suppress this startup message, use: "),
cli::style_italic(crayon_key('suppressPackageStartupMessages(library(SCpubr))\n')),
cli::style_bold(cli::col_red(cli::symbol$cross)),
crayon_body(" Alternatively, you can also set the following option: "),
cli::style_italic(crayon_key('options("SCpubr.verbose" = FALSE)\n')),
crayon_body(" And then load the package normally (and faster) as: "),
cli::style_italic(crayon_key('library(SCpubr)')))
end_rule <- cli::rule(col = "cadetblue")
# Mount all individual messages into a big one that will be then be printed as a packageStartupMessage.
if (isTRUE(startup)){
if (isTRUE(extended)){
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
packages_check, "\n", "\n",
paste(print.list, collapse = "\n"), "\n", "\n",
packages_tip1, "\n",
packages_tip2, "\n", "\n", "\n", "\n",
functions_check, "\n", "\n",
paste(print.list.functions, collapse = "\n"), "\n", "\n",
functions_tip1, "\n",
functions_tip2, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
} else {
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
}
rlang::inform(msg_wrap, class = "packageStartupMessage")
} else if (base::isFALSE(startup)){
if (isTRUE(extended)){
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
packages_check, "\n", "\n",
paste(print.list, collapse = "\n"), "\n", "\n",
packages_tip1, "\n",
packages_tip2, "\n", "\n", "\n", "\n",
functions_check, "\n", "\n",
paste(print.list.functions, collapse = "\n"), "\n", "\n",
functions_tip1, "\n",
functions_tip2, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
} else {
msg_wrap <- paste0("\n", "\n",
header, "\n", "\n",
tutorials, "\n", "\n",
cite, "\n", "\n",
stars, "\n", "\n",
updates, "\n", "\n",
plotting, "\n", "\n", "\n", "\n",
tip_rule, "\n", "\n",
ins_message, "\n", "\n",
tip_message, "\n", "\n",
disable_message, "\n", "\n",
end_rule)
}
rlang::inform(msg_wrap)
}
}
}
#' Check for Seurat class.
#'
#' @param sample Seurat object.
#'
#' @noRd
#' @return None
#'
#' @examples
#' \donttest{
#' TBD
#' }
check_Seurat <- function(sample){
assertthat::assert_that("Seurat" %in% class(sample),
msg = paste0(add_cross(), crayon_body("The provided "),
crayon_key("object"),
crayon_body(" is not a "),
crayon_key("Seurat"),
crayon_body(" object.")))
}
#' Internal check for colors.
#'
#' Adapted from: https://stackoverflow.com/a/13290832.
#
#' @param colors Vector of colors.
#' @param parameter_name The name of the parameter for which we are testing the colors.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_colors <- function(colors, parameter_name = "") {
check <- vapply(colors, function(color) {
tryCatch(is.matrix(grDevices::col2rgb(colors)),
error = function(e) FALSE)
}, FUN.VALUE = logical(1))
# Check for cols.highlight.
assertthat::assert_that(sum(check) == length(colors),
msg = paste0(add_cross(), crayon_body("The colors provided to "),
crayon_key(parameter_name),
crayon_body(" are not valid color representations.\nCheck whether they are accepted "),
crayon_key("R nammes"),
crayon_body(" or "),
crayon_key("HEX codes"),
crayon_body(".")))
}
#' Internal check for named colors and unique values of the grouping variable.
#'
#' @param sample Seurat object.
#' @param colors Named vector of colors.
#' @param grouping_variable Metadata variable in sample to obtain its unique values.
#' @param idents.keep Identities to keep from the grouping_variable.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_consistency_colors_and_names <- function(sample, colors, grouping_variable = NULL, idents.keep = NULL){
# Add lengthy error messages.
withr::local_options(.new = list("warning.length" = 8170))
if (is.null(grouping_variable)){
check_values <- levels(sample)
} else {
if (is.factor(sample@meta.data[, grouping_variable])){
check_values <- levels(sample@meta.data[, grouping_variable])
} else {
check_values <- as.character(unique(sample@meta.data[, grouping_variable]))
}
}
if (!is.null(idents.keep)){
# Remove unwanted idents.
check_values <- check_values[check_values %in% idents.keep]
}
# Remove NAs.
check_values <- check_values[!(is.na(check_values))]
# Remove values that are not in the vector.
if (sum(names(colors) %in% check_values) == length(check_values) & length(names(colors)) > length(check_values)){
colors <- colors[names(colors) %in% check_values]
}
if (base::isFALSE(length(colors) == length(check_values)) | base::isFALSE(sum(names(colors) %in% check_values) == length(check_values))){
format_colors <- function(name, value, colors, max_length){
if (name %in% names(colors)){
name <- paste(c(name, crayon_body(" | "), cli::col_cyan(paste0(colors[[name]]))), collapse = "")
}
func_use <- ifelse(isTRUE(value), cli::col_green(cli::symbol$tick), cli::col_red(cli::symbol$cross))
name_use <- ifelse(isTRUE(value),
cli::ansi_align(crayon_key(name), max_length, align = "left"),
cli::ansi_align(cli::col_red(name), max_length, align = "left"))
paste0(func_use, " ", name_use)
}
color_check <- vapply(check_values, function(x){ifelse(x %in% names(colors), TRUE, FALSE)}, FUN.VALUE = logical(1))
max_length <- max(vapply(check_values, nchar, FUN.VALUE = numeric(1)))
max_length_colors <- max(vapply(unname(colors), nchar, FUN.VALUE = numeric(1)))
length.use <- max_length + 3 + max_length_colors
colors.print <- NULL
for(item in sort(names(color_check))){
colors.print <- append(colors.print, format_colors(name = item, colors = colors, value = color_check[[item]], max_length = length.use))
}
msg <- paste0("\n", "\n",
add_cross(),
crayon_body("The "),
crayon_key("number"),
crayon_body(" or "),
crayon_key("names"),
crayon_body(" of the provided "),
crayon_key("colors"),
crayon_body(" is lower than the "),
crayon_key("number of unique values"),
crayon_body(" in "),
crayon_key("group.by"),
crayon_body(" (which defaults to "),
cli::style_italic(crayon_key("Seurat::Idents(sample)")),
crayon_body(" if "),
crayon_key("NULL"),
crayon_body(")."),
"\n",
add_cross(),
crayon_body("Please check that the "),
crayon_key("colors provided"),
crayon_body(" are a "),
crayon_key("named vector"),
crayon_body(" where the names are the "),
crayon_key("unique values"),
crayon_body(" to which you then assign the "),
crayon_key("colors"),
crayon_body(" to."),
"\n", "\n",
add_warning(),
crayon_body("Example: "),
cli::style_italic(crayon_key('colors.use = c("A" = "red", "B" = "blue")')),
"\n",
"\n", "\n",
crayon_body(cli::rule(left = paste0(crayon_key("Values"), crayon_body(" with an "), cli::col_cyan("assigned color")), width = nchar("Values with an assigned color") + 6)),
"\n", "\n",
paste(colors.print, collapse = "\n"), "\n", "\n")
stop(msg, call. = FALSE)
}
return(colors)
}
#' Generate custom color scale.
#'
#' @param names_use Vector of the names that will go alongside the color scale.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
generate_color_scale <- function(names_use){
# Generate a vector of colors equal to the number of identities in the sample.
colors <- colorspace::qualitative_hcl(length(names_use), palette = "Dark 3")
colors <- grDevices::col2rgb(colors)
colors <- grDevices::rgb2hsv(colors)
colors["v", ] <- colors["v", ] - 0.1
colors["s", ] <- colors["s", ] + 0.2
colors["s", ][colors["s", ] > 1] <- 1
colors <- grDevices::hsv(h = colors["h", ],
s = colors["s", ],
v = colors["v", ],
alpha = 1)
names(colors) <- names_use
return(colors)
}
#' Compute the max and min value of a variable provided to FeaturePlot.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param assay Assay used.
#' @param reduction Reduction used.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_scale_limits <- function(sample, feature, assay = NULL, reduction = NULL, slot = NULL){
if (is.null(assay)){
assay <- Seurat::DefaultAssay(sample)
}
if (is.null(reduction)){
for(red in Seurat::Reductions(object = sample)){
if (feature %in% colnames(sample@reductions[[red]][[]])){
reduction <- red
}
}
}
if (is.null(slot)){
slot <- "data"
}
if (feature %in% rownames(sample)){
suppressWarnings({
data.check <- SeuratObject::GetAssayData(sample,
assay = assay,
slot = slot)[feature, ]
})
scale.begin <- min(data.check, na.rm = TRUE)
scale.end <- max(data.check, na.rm = TRUE)
} else if (feature %in% colnames(sample@meta.data)){
if (is.factor(sample@meta.data[, feature])){
sample@meta.data[, feature] <- as.character(sample@meta.data[, feature])
}
scale.begin <- min(sample@meta.data[, feature], na.rm = TRUE)
scale.end <- max(sample@meta.data[, feature], na.rm = TRUE)
} else if (feature %in% colnames(sample@reductions[[reduction]][[]])){
scale.begin <- min(sample@reductions[[reduction]][[]][, feature], na.rm = TRUE)
scale.end <- max(sample@reductions[[reduction]][[]][, feature], na.rm = TRUE)
}
return(list("scale.begin" = scale.begin,
"scale.end" = scale.end))
}
#' Check cutoffs
#'
#' @param min.cutoff Min cutoff.
#' @param max.cutoff Max cutoff.
#' @param limits Computed range.
#' @param feature Feature name, if any.
#' @return A list.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_cutoffs <- function(min.cutoff,
max.cutoff,
limits,
feature = ""){
outlier.data <- FALSE
if (!is.na(min.cutoff) & !is.na(max.cutoff)){
assertthat::assert_that(min.cutoff < max.cutoff,
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(") has to be lower than the value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(").")))
}
if (!is.na(min.cutoff)){
assertthat::assert_that(min.cutoff >= limits[1],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") is lower than the minimum value ("),
crayon_key(limits[1]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
assertthat::assert_that(min.cutoff <= limits[2],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("min.cutoff"),
crayon_body(" ("),
crayon_key(min.cutoff),
crayon_body(") is higher than the maximum value ("),
crayon_key(limits[2]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
limits <- c(min.cutoff, limits[2])
outlier.data <- TRUE
}
if (!is.na(max.cutoff)){
assertthat::assert_that(max.cutoff <= limits[2],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(") is higher than the maximum value ("),
crayon_key(limits[2]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
assertthat::assert_that(max.cutoff >= limits[1],
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key("max.cutoff"),
crayon_body(" ("),
crayon_key(max.cutoff),
crayon_body(") is lower than the minimum value ("),
crayon_key(limits[1]),
crayon_body(") for the feature ("),
crayon_key(feature),
crayon_body(").")))
limits <- c(limits[1], max.cutoff)
outlier.data <- TRUE
}
return.list <- list("outlier.data" = outlier.data,
"limits" = limits)
return(return.list)
}
#' Compute the scales for a given ggplot2-based plot.
#'
#' @param sample Seurat object.
#' @param feature Feature to compute scales to.
#' @param assay Assay to retrieve data from.
#' @param reduction Reduction to use if the feature is a dimred component.
#' @param slot Slot to retrieve the values from if feature is a gene.
#' @param flavor Whether it is a seurat plot or ggplot2-based plots.
#' @param number.breaks Number of desired breaks in the scale.
#' @param min.cutoff Minimum cutoff for the scale.
#' @param max.cutoff Maximum cutoff for the scale.
#' @param from_data Provide a matrix already.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_scales <- function(sample,
feature = "",
assay = NULL,
reduction = NULL,
slot,
flavor,
number.breaks,
min.cutoff,
max.cutoff,
enforce_symmetry,
from_data = FALSE,
limits.use = NULL,
center_on_value = FALSE,
value_center = NULL){
if (base::isFALSE(from_data)){
limits <- compute_scale_limits(sample = sample,
feature = feature,
assay = assay,
reduction = reduction,
slot = slot)
limits <- c(limits$scale.begin, limits$scale.end)
} else {
limits <- limits.use
}
out <- check_cutoffs(min.cutoff = min.cutoff,
max.cutoff = max.cutoff,
limits = limits,
feature = feature)
limits <- out$limits
if (isTRUE(enforce_symmetry)){
if (base::isFALSE(center_on_value)){
end_value <- max(abs(limits))
limits <- c(-end_value, end_value)
} else {
low_end <- value_center - limits[1]
high_end <- limits[2] - value_center
value.use <- max(c(low_end, high_end))
limits <- c(1 - value.use, 1 + value.use)
}
}
breaks <- labeling::extended(dmin = limits[1],
dmax = limits[2],
m = number.breaks)
labels <- as.character(breaks)
if (!is.na(min.cutoff)){
if (isTRUE(min.cutoff == breaks[1])){
breaks[1] <- min.cutoff
labels[1] <- paste0(as.character(expression("\u2264")), " ", min.cutoff)
}
}
if (!is.na(max.cutoff)){
if (isTRUE(max.cutoff == breaks[length(breaks)])){
breaks[length(breaks)] <- max.cutoff
labels[length(labels)] <- paste0(as.character(expression("\u2265")), " ", max.cutoff)
}
}
# Fix for the one value limit.
if(limits[[1]] == limits[[2]]){
breaks <- limits[[1]]
labels <- as.character(limits[[1]])
}
return.obj <- list("limits" = limits,
"breaks" = breaks,
"labels" = labels)
return(return.obj)
}
#' Check if a value is in the range of the values.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param assay Assay used.
#' @param reduction Reduction used.
#' @param value Value to check.
#' @param value_name Name of the value.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_limits <- function(sample, feature, value_name, value, assay = NULL, reduction = NULL){
limits <- compute_scale_limits(sample = sample, feature = feature, assay = assay, reduction = reduction)
assertthat::assert_that(limits[["scale.begin"]] <= value & limits[["scale.end"]] >= value,
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key(value_name),
crayon_body(" ("),
crayon_key(value),
crayon_body(") is not in the range of values of "),
crayon_key(feature),
crayon_body(", whis is:\nMin: "),
crayon_key(limits[["scale.begin"]]),
crayon_body(".\nMax:"),
crayon_key(limits[["scale.end"]]),
crayon_body(".")))
}
#' Check if the feature to plot is in the Seurat object.
#'
#' @param sample Seurat object.
#' @param features Feature to plot.
#' @param dump_reduction_names Whether to return the reduction colnames.
#' @param permissive Throw a warning or directly stops if the feature is not found.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_feature <- function(sample, features, permissive = FALSE, dump_reduction_names = FALSE, enforce_check = NULL, enforce_parameter = NULL){
if (is.list(features)){
features_check <- unlist(features)
} else {
features_check <- features
}
check_enforcers <- list() # Store the results of the checks.
not_found_features <- NULL # Store the features not found.
# Check each of the features.
for (feature in features_check){
check <- 0
if (!(feature %in% rownames(sample))){
check <- check + 1
check_enforcers[["gene"]] <- FALSE
} else {
check_enforcers[["gene"]] <- TRUE
}
if (!(feature %in% colnames(sample@meta.data))){
check <- check + 1
check_enforcers[["metadata"]] <- FALSE
} else {
check_enforcers[["metadata"]] <- TRUE
}
dim_colnames <- NULL
for(red in Seurat::Reductions(object = sample)){
dim_colnames <- append(dim_colnames, colnames(sample@reductions[[red]][[]]))
}
if (!(feature %in% dim_colnames)){
check <- check + 1
check_enforcers[["reductions"]] <- FALSE
} else {
check_enforcers[["reductions"]] <- TRUE
}
if (check == 3) {
not_found_features <- append(not_found_features, feature)
}
}
# Return the error logs if there were features not found.
if (length(not_found_features) > 0){
if (isTRUE(permissive)){
# Stop if neither of the features are found.
assertthat::assert_that(length(unlist(not_found_features)) != length(unlist(features)),
msg = "Neither of the provided features are found.")
warning(paste0(add_warning(), crayon_body("The following "),
crayon_key("features"),
crayon_body(" were not be found:"),
paste(vapply(not_found_features, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")), call. = FALSE)
features_out <- remove_not_found_features(features = features, not_found_features = not_found_features)
} else if (base::isFALSE(permissive)){
assertthat::assert_that(length(not_found_features) == 0,
msg = paste0(add_cross(), crayon_body("The following "),
crayon_key("features"),
crayon_body(" were not be found:"),
paste(vapply(not_found_features, crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
}
} else {
features_out <- features
}
# If we are enforcing a given check (i.e: the feature being in the metadata).
if (!(is.null(enforce_check))){
assertthat::assert_that(enforce_check %in% names(check_enforcers),
msg = "The variable enforcer is not in the current list of checked variable types.")
assertthat::assert_that(isTRUE(check_enforcers[[enforce_check]]),
msg = paste0(add_cross(), crayon_body("Feature "),
crayon_key(enforce_parameter),
crayon_key(" = "),
crayon_key(feature),
crayon_body(" not found in "),
crayon_key(enforce_check),
crayon_body(".")))
}
# Return options.
if (isTRUE(dump_reduction_names) & base::isFALSE(permissive)){return(dim_colnames)}
if (isTRUE(permissive) & base::isFALSE(dump_reduction_names)){return(features_out)}
if (isTRUE(dump_reduction_names) & isTRUE(permissive)){return(list("features" = features_out, "reduction_names" = dim_colnames))}
}
#' Remove not found features
#'
#' @param features Features to check.
#' @param not_found_features Features to exclude.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
remove_not_found_features <- function(features, not_found_features){
if (is.character(features)){
features_out <- features[!(features %in% not_found_features)]
} else if (is.list(features)){
features_out <- list()
for (list_name in names(features)){
genes <- features[[list_name]]
genes_out <- genes[!(genes %in% not_found_features)]
features_out[[list_name]] <- genes_out
}
}
return(features_out)
}
#' Remove duplicated features.
#'
#' @param features Features to check.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
remove_duplicated_features <- function(features){
if (is.character(features)){
check <- sum(duplicated(features))
if (check > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(features[duplicated(features)])),
crayon_body(".\nExcluding them from the analysis.")), call. = FALSE)
features <- features[!(duplicated(features))]
}
} else if (is.list(features)){
features_out <- list()
all_genes <- NULL # Will update with the genes as they iterate to check duplicates.
for (list_name in names(features)){
genes <- features[[list_name]]
# Remove genes duplicated within the list.
if (sum(duplicated(genes)) > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(genes[duplicated(genes)], collapse = ", ")),
crayon_body("\nIn the list named: "),
crayon_key(list_name),
crayon_body(".\nExcluding them from the analysis.")), call. = FALSE)
}
genes <- genes[!(duplicated(genes))]
# Remove genes duplicated in the vector of all genes.
duplicated_features <- genes[genes %in% all_genes]
all_genes <- append(all_genes, genes[!(genes %in% all_genes)])
genes <- genes[!(genes %in% duplicated_features)]
if (length(duplicated_features) > 0){
warning(paste0(add_warning(), crayon_body("Found duplicated features:\n"),
crayon_key(paste(duplicated_features, collapse = ", ")),
crayon_body("\nIn the list named: "),
crayon_key(list_name),
crayon_body(" with regards to the other lists. \nExcluding them from the analysis.")), call. = FALSE)
}
features_out[[list_name]] <- genes
}
features <- features_out
}
return(features)
}
#' Check if the identity provided is in the current Seurat identities.
#'
#' @param sample Seurat object.
#' @param identities Identities to test.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_identity <- function(sample, identities){
for (identity in identities){
assertthat::assert_that(identity %in% levels(sample),
msg = paste0(add_cross(), crayon_body("Could not find identity "),
crayon_key(identity),
crayon_body(" in the current active identities of the object.")))
}
}
#' Check the reduction provided and set it up.
#'
#' @param sample Seurat sample.
#' @param reduction Reduction.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_reduction <- function(sample, reduction = NULL){
# Check if the object has a reduction computed.
assertthat::assert_that(length(Seurat::Reductions(sample)) != 0,
msg = paste0(add_cross(), crayon_body("The Seurat object has no "),
crayon_key("reductions"),
crayon_body(" computed.")))
# If no reduction was provided by the user.
if (is.null(reduction)){
# Select umap if computed.
if ("umap" %in% Seurat::Reductions(sample)){
reduction <- "umap"
} else {
# Select the last computed one.
reduction <- Seurat::Reductions(sample)[length(Seurat::Reductions(sample))]
}
# If the user provided a value for reduction.
} else if (!(is.null(reduction))){
# Check if the provided reduction is in the list.
assertthat::assert_that(reduction %in% Seurat::Reductions(sample),
msg = paste0(add_cross(), crayon_body("The provided "),
crayon_key("reduction"),
crayon_body(" could not be found in the object: "),
crayon_key(reduction),
crayon_body(".")))
}
return(reduction)
}
#' Check the provided dimensions and set them up.
#'
#' @param sample Seurat object.
#' @param reduction Provided reduction.
#' @param dims Provided dimensions.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_dimensions <- function(sample, reduction = NULL, dims = NULL){
# If reduction is null, select the last computed one.
if (is.null(reduction)){
reduction <- Seurat::Reductions(sample)[length(Seurat::Reductions(sample))]
}
# Check that the dimensions is a 2 item vector.
if (!is.null(dims)){
assertthat::assert_that(length(dims) == 2,
msg = paste0(add_cross(), crayon_body("You need to provide a vector of "),
crayon_key("two values"),
crayon_body(" to "),
crayon_key("dims"),
crayon_body(".")))
# Check that at least 2 dimensions are present.
aval_dims <- length(colnames(Seurat::Embeddings(sample[[reduction]])))
assertthat::assert_that(aval_dims >= 2,
msg = paste0(add_cross(), crayon_body("There need to be at least "),
crayon_key("two available dimensions"),
crayon_body(" computed.")))
# Check that the dimensions are integers.
null_check <- is.null(dims[1]) & is.null(dims[2])
integer_check <- is.numeric(dims[1]) & is.numeric(dims[1])
assertthat::assert_that(base::isFALSE(null_check) & isTRUE(integer_check),
msg = paste0(add_cross(), crayon_body("The dimensions provided to "),
crayon_key("dims"),
crayon_body(" need to be of class "),
crayon_key("numeric"),
crayon_body(".")))
# Check that the dimensions are in the requested embedding.
assertthat::assert_that(dims[1] %in% seq_len(aval_dims) & dims[2] %in% seq_len(aval_dims),
msg = paste0(add_cross(), crayon_body("The dimensions provided to "),
crayon_key("dims"),
crayon_body(" could not be found in the following reduction: "),
crayon_key(reduction),
crayon_body(".")))
} else {
# If no dimensions were provided, fall back to first and second.
dims <- c(1, 2)
}
return(dims)
}
#' Check and set the provided assay.
#'
#' @param sample Seurat object.
#' @param assay Provided assay.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_assay <- function(sample, assay = NULL){
# Check that at least one assay is computed.
assertthat::assert_that(length(Seurat::Assays(sample)) != 0,
msg = paste0(add_cross(), crayon_body("There must be at least "),
crayon_key("one computed assay"),
crayon_body(" in the Seurat object.")))
# If assay is null, set it to the active one.
if (is.null(assay)){
assay <- Seurat::DefaultAssay(sample)
} else {
# Check if the assay is a character.
assertthat::assert_that(is.character(assay),
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key("assay"),
crayon_body(" needs to of class "),
crayon_key("character"),
crayon_body(".")))
# Check that the assay is in the available assays.
aval_assays <- Seurat::Assays(sample)
assertthat::assert_that(assay %in% aval_assays,
msg = paste0(add_cross(), crayon_body("The following "),
crayon_key("assay"),
crayon_body(" was not found: "),
crayon_key(assay),
crayon_body(".")))
}
# Set up the assay the user has defined.
if (assay != Seurat::DefaultAssay(sample)){
Seurat::DefaultAssay(sample) <- assay
}
return(list("sample" = sample,
"assay" = assay))
}
#' Check a parameter for a given class.
#'
#' @param parameters List of named parameters to test.
#' @param required_type Name of the required class.
#' @param test_function Testing function.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_type <- function(parameters, required_type, test_function){
for(parameter_name in names(parameters)){
# Get each individual parameter from the list.
parameter <- parameters[[parameter_name]]
# Cases in which the user has to provide a vector.
# Check if the parameter is not NULL already.
if (!(is.null(parameter))){
# For each parameter in the vector.
for (item in parameter){
# If not null.
if (!(is.null(item))){
# If not NA, if the testing function fails, report it.
if (sum(!(is.na(item))) > 0){
assertthat::assert_that(sum(test_function(item)) > 0,
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key(parameter_name),
crayon_body(" needs to be of class "),
crayon_key(required_type),
crayon_body(".")))
}
}
}
}
}
}
#' Check the slots.
#'
#' @param slot Slot provided.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_and_set_slot <- function(slot){
if (is.null(slot)){
slot <- "data"
} else {
assertthat::assert_that(slot %in% c("counts", "data", "scale.data"),
msg = paste0(crayon_body("Parameter "),
crayon_key("slots"),
crayon_body(" needs to be either "),
crayon_key("counts"),
crayon_body(", "),
crayon_key("data"),
crayon_body(", or "),
crayon_key("scale.data"),
crayon_body(".")))
}
return(slot)
}
#' Compute the order of the plotted bars for do_BarPlot.
#'
#' @param sample Seurat object.
#' @param feature Feature to plot.
#' @param group.by Feature to group the output by.
#' @param order Whether to arrange the values.
#' @param order.by Unique value in group.by to reorder labels in descending order.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_factor_levels <- function(sample, feature, position, group.by = NULL, order = FALSE, order.by = FALSE, assay = "SCT", slot = "data"){
`%>%` <- magrittr::`%>%`
assertthat::assert_that(position %in% c("stack", "fill"),
msg = paste0(add_cross(), crayon_body("Parameter "),
crayon_key("position"),
crayon_body(" needs to be either "),
crayon_key("stack"),
crayon_body(" or "),
crayon_key("fill"),
crayon_body(".")))
if (is.null(group.by)){
sample@meta.data[, "group.by"] <- sample@active.ident
} else {
sample@meta.data[, "group.by"] <- sample@meta.data[, group.by]
}
group.by <- "group.by"
if (base::isFALSE(order)){
factor_levels <- as.character(rev(sort(unique(sample@meta.data[, group.by]))))
} else if (isTRUE(order)){
factor_levels <- get_data_column_in_context(sample = sample,
feature = feature,
group.by = group.by,
assay = assay,
slot = slot) %>%
dplyr::group_by(.data$group.by) %>%
dplyr::summarise("value" = if(is.double(.data$feature)){dplyr::across(.cols = dplyr::all_of("feature"), mean)} else {"feature" <- dplyr::n()}) %>%
dplyr::mutate("feature" = if (position == "fill") {.data$value / sum(.data$value)} else {.data$value}) %>%
dplyr::arrange(dplyr::desc(.data$feature)) %>%
dplyr::pull(.data$group.by) %>%
as.character()
}
return(factor_levels)
}
#' Check length of parameters compared to features.
#'
#' @param vector_of_parameters Vector of parameters to test.
#' @param vector_of_features Vector of features to test against.
#' @param parameters_name Name of the parameters variable.
#' @param features_name Name of the features variable.
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_length <- function(vector_of_parameters,
vector_of_features,
parameters_name,
features_name){
assertthat::assert_that(length(vector_of_parameters) == length(vector_of_features),
msg = paste0(add_cross(), crayon_body("The length of "),
crayon_key(parameters_name),
crayon_body(" is not equal to the length of "),
crayon_key(features_name),
crayon_body(".")))
}
#' Add viridis color scale while suppressing the warning that comes with adding a second scale.
#'
#' @param p GGplot2 plot.
#' @param num_plots Number of plots.
#' @param function_use Coloring function to use.
#' @param scale Name of the scale. Either fill or color.
#' @param limits Whether to put limits.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
add_scale <- function(p, scale, function_use, num_plots = 1, limits = NULL){
if (scale == "color"){scale <- "colour"}
# Compute the number of plots in this object (maybe a more efficient solution exists).
if (num_plots == 1){
# Find the index in which the scale is stored.
# Adapted from: https://stackoverflow.com/a/46003178
x <- which(vapply(p$scales$scales, function(x){scale %in% x$aesthetics}, FUN.VALUE = logical(1)))
# Remove it.
p$scales$scales[[x]] <- NULL
} else {
for (i in seq(1, num_plots)){
# Find the index in which the scale is stored.
# Adapted from: https://stackoverflow.com/a/46003178
x <- which(vapply(p[[i]]$scales$scales, function(x){scale %in% x$aesthetics}, FUN.VALUE = logical(1)))
# Remove it.
p[[i]]$scales$scales[[x]] <- NULL
}
}
# Add the scale and now it will now show up a warning since we removed the previous scale.
p <- p & function_use
return(p)
}
#' Modify a string to wrap it around the middle point.
#'
#' @param string_to_modify
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
modify_string <- function(string_to_modify){
words <- stringr::str_split(string_to_modify, " ")[[1]]
num_words <- length(words)
middle_point <- round(num_words / 2, 0)
string_to_modify <- paste(paste(words[1:middle_point], collapse = " "), "\n",
paste(words[(middle_point + 1):num_words], collapse = " "))
return(string_to_modify)
}
#' Compute Enrichment scores using Seurat::AddModuleScore()
#'
#' @param sample Seurat object.
#' @param input_gene_list Named list of genes to compute enrichment for.
#' @param verbose Verbose output.
#' @param nbin Number of bins.
#' @param ctrl Number of control genes.
#' @param norm_data Whether to 0-1 normalize the data
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_enrichment_scores <- function(sample,
input_gene_list,
verbose = FALSE,
nbin = 24,
ctrl = 100,
assay = NULL,
slot = NULL,
flavor = "Seurat",
ncores = 1,
storeRanks = TRUE,
norm_data = FALSE){
`%>%` <- magrittr::`%>%`
# Checks for UCell.
if (flavor == "UCell"){
R_version <- paste0(R.version$major, ".", R.version$minor)
assertthat::assert_that(R_version >= "4.2.0",
msg = paste0(crayon_body("To run "),
crayon_key("UCell scoring"),
crayon_body(", R version "),
crayon_key("4.2.0"),
crayon_body(" is required. Please select "),
crayon_key("flavor = 'Seurat'"),
crayon_body(" if you are running a lower version.")))
if (!requireNamespace("UCell", quietly = TRUE)) {
# nocov start
stop(paste0(add_cross(), crayon_body("Package "), crayon_key("UCell"), crayon_body(" must be installed to run UCell scoring.")), call. = FALSE)
# nocov end
}
}
if (!is.list(input_gene_list) & is.character(input_gene_list)){
input_gene_list <- list("Input" = input_gene_list)
}
for (celltype in names(input_gene_list)){
list_markers <- list(input_gene_list[[celltype]])
if (flavor == "Seurat"){
# Compute Seurat AddModuleScore as well.
if (verbose){
sample <- Seurat::AddModuleScore(sample,
list_markers,
name = celltype,
search = TRUE,
verbose = TRUE,
nbin = nbin,
ctrl = ctrl,
assay = assay)
} else {
sample <- suppressMessages(suppressWarnings(Seurat::AddModuleScore(sample,
list_markers,
name = celltype,
search = TRUE,
verbose = FALSE,
nbin = nbin,
ctrl = ctrl,
assay = assay)))
}
# Retrieve the scores.
col_name <- stringr::str_replace_all(paste0(celltype, "1"), " ", ".")
col_name <- stringr::str_replace_all(col_name, "-", ".")
col_name <- stringr::str_replace_all(col_name, "\\+", ".")
# Modify the name that Seurat::AddModuleScore gives by default.
sample@meta.data[, celltype] <- sample@meta.data[, col_name]
# Remove old metadata.
sample@meta.data[, col_name] <- NULL
}
}
if (flavor == "UCell"){
list.names <- NULL
for (celltype in names(input_gene_list)){
col_name <- celltype
col_name <- stringr::str_replace_all(col_name, "-", ">")
col_name <- stringr::str_replace_all(col_name, " ", "_")
col_name <- stringr::str_replace_all(col_name, "\\+", ".")
list.names <- append(list.names, col_name)
}
list.originals <- names(input_gene_list)
names(input_gene_list) <- list.names
sample <- UCell::AddModuleScore_UCell(obj = sample,
features = input_gene_list,
assay = assay,
slot = if (is.null(slot)){"data"} else {slot},
name = "",
ncores = ncores,
storeRanks = storeRanks)
for (i in seq_len(length(list.names))){
old.name <- list.originals[i]
mod.name <- list.names[i]
# Modify the name that Seurat::AddModuleScore gives by default.
sample@meta.data[, old.name] <- sample@meta.data[, mod.name]
# Remove old metadata.
if (old.name != mod.name){
# nocov start
sample@meta.data[, mod.name] <- NULL
# nocov end
}
}
}
if (isTRUE(norm_data)){
# Compute a 0-1 normalization.
for (name in names(input_gene_list)){
sample@meta.data[, name] <- zero_one_norm(sample@meta.data[, name])
}
}
return(sample)
}
#' Modify the aspect of the legend.
#'
#' @param p Plot.
#' @param legend.aes Character. Either color or fill.
#' @param legend.type Character. Type of legend to display. One of: normal, colorbar.
#' @param legend.position Position of the legend in the plot. Will only work if legend is set to TRUE.
#' @param legend.framewidth,legend.tickwidth Width of the lines of the box in the legend.
#' @param legend.framecolor,legend.tickcolor Color of the lines of the box in the legend.
#' @param legend.length,legend.width Length and width of the legend. Will adjust automatically depending on legend side.
#' @param legend.title Character. Title for the legend.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
modify_continuous_legend <- function(p,
legend.aes,
legend.type,
legend.position,
legend.length,
legend.width,
legend.framecolor,
legend.tickcolor,
legend.tickwidth,
legend.framewidth,
legend.title = NULL){
# Define legend parameters. Width and height values will change depending on the legend orientation.
if (legend.position %in% c("top", "bottom", "none")){
legend.barwidth <- legend.length
legend.barheight <- legend.width
} else if (legend.position %in% c("left", "right")){
legend.barwidth <- legend.width
legend.barheight <- legend.length
}
legend.title <- if (is.null(legend.title)){ggplot2::waiver()} else {legend.title}
if (legend.aes == "color" | legend.aes == "colour"){
if (legend.type == "normal"){
p <- p +
ggplot2::guides(color = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
title.hjust = 0.5))
} else if (legend.type == "colorbar"){
p <- p +
ggplot2::guides(color = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
barwidth = legend.barwidth,
barheight = legend.barheight,
title.hjust = 0.5,
ticks.linewidth = legend.tickwidth,
frame.linewidth = legend.framewidth,
frame.colour = legend.framecolor,
ticks.colour = legend.tickcolor))
}
} else if (legend.aes == "fill"){
if (legend.type == "normal"){
p <- p +
ggplot2::guides(fill = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
title.hjust = 0.5))
} else if (legend.type == "colorbar"){
p <- p +
ggplot2::guides(fill = ggplot2::guide_colorbar(title = legend.title,
title.position = "top",
barwidth = legend.barwidth,
barheight = legend.barheight,
title.hjust = 0.5,
ticks.linewidth = legend.tickwidth,
frame.linewidth = legend.framewidth,
frame.colour = legend.framecolor,
ticks.colour = legend.tickcolor))
}
}
return(p)
}
#' Return a column with the desired values of a feature per cell.
#'
#' @param sample Seurat object.
#' @param feature Feature to retrieve data.
#' @param assay Assay to pull data from.
#' @param slot Slot from the assay to pull data from.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_data_column <- function(sample,
feature,
assay,
slot){
`%>%` <- magrittr::`%>%`
dim_colnames <- NULL
for(red in Seurat::Reductions(object = sample)){
col.names <- colnames(sample@reductions[[red]][[]])
dim_colnames <- append(dim_colnames, col.names)
if (feature %in% col.names){
# Get the reduction in which the feature is, if this is the case.
reduction <- red
}
}
if (isTRUE(feature %in% colnames(sample@meta.data))){
feature_column <- sample@meta.data %>%
dplyr::select(dplyr::all_of(c(feature))) %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
} else if (isTRUE(feature %in% rownames(sample))){
suppressWarnings({
feature_column <- SeuratObject::GetAssayData(object = sample,
assay = assay,
slot = slot)[feature, , drop = FALSE] %>%
as.matrix() %>%
t() %>%
as.data.frame() %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
})
} else if (isTRUE(feature %in% dim_colnames)){
feature_column <- sample@reductions[[reduction]][[]][, feature, drop = FALSE] %>%
as.data.frame() %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::rename("feature" = dplyr::all_of(c(feature)))
}
return(feature_column)
}
#' Return a column with the desired values of a feature per cell.
#'
#' @param sample Seurat object.
#' @param feature Feature to retrieve data.
#' @param assay Assay to pull data from.
#' @param group.by Parameter used later on for grouping.
#' @param split.by Parameter used later on for splitting.
#' @param slot Slot from the assay to pull data from.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_data_column_in_context <- function(sample,
feature,
assay,
slot,
group.by = NULL,
split.by = NULL){
`%>%` <- magrittr::`%>%`
if (is.null(group.by)){
sample@meta.data[, "group.by"] <- sample@active.ident
} else {
sample@meta.data[, "group.by"] <- sample@meta.data[, group.by]
}
group.by <- "group.by"
vars <- c("cell", "group.by")
if (!is.null(split.by)){
sample@meta.data[, "split.by"] <- sample@meta.data[, split.by]
vars <- c(vars, "split.by")
}
data <- sample@meta.data %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::select(dplyr::all_of(vars)) %>%
dplyr::left_join(y = get_data_column(sample = sample,
feature = feature,
assay = assay,
slot = slot),
by = "cell") %>%
tibble::as_tibble()
return(data)
}
#' Check parameters.
#'
#' @param parameter Parameter to check
#' @param parameter_name Name of the parameter.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_parameters <- function(parameter,
parameter_name){
if (parameter_name == "font.type"){
# Check font.type.
assertthat::assert_that(parameter %in% c("sans", "serif", "mono"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("sans"),
crayon_body(", "),
crayon_key("serif"),
crayon_body(", "),
crayon_key("mono"),
crayon_body(".")))
} else if (parameter_name == "legend.type"){
# Check the legend.type.
assertthat::assert_that(parameter %in% c("normal", "colorbar"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("normal"),
crayon_body(", "),
crayon_key("colorbar"),
crayon_body(".")))
} else if (parameter_name == "legend.position"){
# Check the legend.position.
assertthat::assert_that(parameter %in% c("top", "bottom", "left", "right", "none"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("top"),
crayon_body(", "),
crayon_key("bottom"),
crayon_body(", "),
crayon_key("left"),
crayon_body(", "),
crayon_key("right"),
crayon_body(", "),
crayon_key("none"),
crayon_body(".")))
} else if (parameter_name == "marginal.type"){
# Check marginal.type.
assertthat::assert_that(parameter %in% c("density", "histogram", "boxplot", "violin", "densigram"),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("density"),
crayon_body(", "),
crayon_key("histogram"),
crayon_body(", "),
crayon_key("boxplot"),
crayon_body(", "),
crayon_key("violin"),
crayon_body(", "),
crayon_key("densigram"),
crayon_body(".")))
} else if (parameter_name == "viridis.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "sequential.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "diverging.direction"){
assertthat::assert_that(parameter %in% c(1, -1),
msg = paste0(crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "viridis.palette"){
viridis_options <- c("A", "B", "C", "D", "E", "F", "G", "H", "magma", "inferno", "plasma", "viridis", "cividis", "rocket", "mako", "turbo")
assertthat::assert_that(parameter %in% viridis_options,
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("A"),
crayon_body(", "),
crayon_key("B"),
crayon_body(", "),
crayon_key("C"),
crayon_body(", "),
crayon_key("D"),
crayon_body(", "),
crayon_key("E"),
crayon_body(", "),
crayon_key("F"),
crayon_body(", "),
crayon_key("G"),
crayon_body(", "),
crayon_key("H"),
crayon_body(", "),
crayon_key("magma"),
crayon_body(", "),
crayon_key("inferno"),
crayon_body(", "),
crayon_key("plasma"),
crayon_body(", "),
crayon_key("viridis"),
crayon_body(", "),
crayon_key("cividis"),
crayon_body(", "),
crayon_key("rocket"),
crayon_body(", "),
crayon_key("mako"),
crayon_body(", "),
crayon_key("turbo"),
crayon_body(".")))
} else if (parameter_name == "grid.type"){
assertthat::assert_that(parameter %in% c("blank", "solid", "dashed", "dotted", "dotdash", "longdash", "twodash"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("blank"),
crayon_body(", "),
crayon_key("solid"),
crayon_body(", "),
crayon_key("dashed"),
crayon_body(", "),
crayon_key("dotted"),
crayon_body(", "),
crayon_key("dotdash"),
crayon_body(", "),
crayon_key("longdash"),
crayon_body(", "),
crayon_key("twodash"),
crayon_body(".")))
} else if (parameter_name == "direction.type"){
for (item in parameter){
assertthat::assert_that(item %in% c("diffHeight", "arrows"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("diffHeight"),
crayon_body(", "),
crayon_key("arrows"),
crayon_body(", "),
crayon_key("both"),
crayon_body(".")))
}
} else if (parameter_name == "self.link"){
assertthat::assert_that(parameter %in% c(1, 2),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("1"),
crayon_body(", "),
crayon_key("2"),
crayon_body(".")))
} else if (parameter_name == "directional"){
assertthat::assert_that(parameter %in% c(0, 1, 2, -1),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("0"),
crayon_body(", "),
crayon_key("1"),
crayon_body(", "),
crayon_key("2"),
crayon_body(", "),
crayon_key("-1"),
crayon_body(".")))
} else if (parameter_name == "link.arr.type"){
assertthat::assert_that(parameter %in% c("big.arrow", "triangle"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("big.arrow"),
crayon_body(", "),
crayon_key("triangle"),
crayon_body(".")))
} else if (parameter_name == "alignment"){
assertthat::assert_that(parameter %in% c("default", "vertical", "horizontal"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("vertical"),
crayon_body(", "),
crayon_key("horizontal"),
crayon_body(".")))
} else if (parameter_name == "alpha.highlight"){
assertthat::assert_that(parameter %in% c(seq(1, 99), "FF"),
msg = paste0(add_cross(), crayon_body("Please provide either "),
crayon_key("FF"),
crayon_body(" or a number between "),
crayon_key("1"),
crayon_body(" and "),
crayon_key("99"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "scale_type"){
assertthat::assert_that(parameter %in% c("categorical", "continuous"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("categorical"),
crayon_body(", "),
crayon_key("continuous"),
crayon_body(".")))
} else if (parameter_name == "axis.text.x.angle"){
assertthat::assert_that(parameter %in% c(0, 45, 90),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("0"),
crayon_body(", "),
crayon_key("45"),
crayon_body(", "),
crayon_key("90"),
crayon_body(".")))
} else if (parameter_name == "contour.lineend"){
assertthat::assert_that(parameter %in% c("round", "butt", "square"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("round"),
crayon_body(", "),
crayon_key("butt"),
crayon_body(", "),
crayon_key("square"),
crayon_body(".")))
} else if (parameter_name == "contour.linejoin"){
assertthat::assert_that(parameter %in% c("round", "mitre", "bevel"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("round"),
crayon_body(", "),
crayon_key("mitre"),
crayon_body(", "),
crayon_key("bevel"),
crayon_body(".")))
} else if (parameter_name == "contour.position"){
assertthat::assert_that(parameter %in% c("bottom", "top"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("top"),
crayon_body(", "),
crayon_key("bottom"),
crayon_body(".")))
} else if (parameter_name == "flavor"){
assertthat::assert_that(parameter %in% c("Seurat", "UCell"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("Seurat"),
crayon_body(", "),
crayon_key("UCell"),
crayon_body(".")))
} else if (parameter_name == "database"){
assertthat::assert_that(parameter %in% c("GO", "KEGG"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("GO"),
crayon_body(", "),
crayon_key("KEGG"),
crayon_body(".")))
} else if (parameter_name == "GO_ontology"){
assertthat::assert_that(parameter %in% c("BP", "MF", "CC"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("BP"),
crayon_body(", "),
crayon_key("MF"),
crayon_body(", "),
crayon_key("CC"),
crayon_body(".")))
} else if (parameter_name == "pAdjustMethod"){
assertthat::assert_that(parameter %in% c("holm", "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
crayon_key("holm"),
crayon_body(", "),
crayon_key("hochberg"),
crayon_body(", "),
crayon_key("bonferroni"),
crayon_body(", "),
crayon_key("BH"),
crayon_body(", "),
crayon_key("BY"),
crayon_body(", "),
crayon_key("fdr"),
crayon_body(", "),
crayon_key("none"),
crayon_body(".")))
} else if (parameter_name == "number.breaks"){
assertthat::assert_that(parameter >= 2,
msg = paste0(add_cross(), crayon_body("Please provide a value higher or equal to "),
crayon_key("2"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "border.density"){
assertthat::assert_that(parameter >= 0 & parameter <= 1,
msg = paste0(add_cross(), crayon_body("Please provide a value between "),
crayon_key("0"),
crayon_body(" and "),
crayon_key("1"),
crayon_body(" to "),
crayon_key(parameter_name),
crayon_body(".")))
} else if (parameter_name == "diverging.palette"){
assertthat::assert_that(parameter %in% c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name == "sequential.palette"){
assertthat::assert_that(parameter %in% c("Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name %in% c("plot.title.face", "plot.subtitle.face", "plot.caption.face", "axis.title.face", "axis.text.face", "legend.title.face", "legend.text.face", "strip.text.face")){
assertthat::assert_that(parameter %in% c("plain", "italic", "bold", "bold.italic"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("plain", "italic", "bold", "bold.italic"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
} else if (parameter_name %in% c("symmetry.type")){
assertthat::assert_that(parameter %in% c("absolute", "centered"),
msg = paste0(add_cross(), crayon_body("Please provide one of the following to "),
crayon_key(parameter_name),
crayon_body(": "),
paste(vapply(c("absolute", "centered"), crayon_key, FUN.VALUE = character(1)), collapse = crayon_body(", ")),
crayon_body(".")))
}
}
#' Helper for do_AlluvialPlot.
#'
#' @param data Data to plot.
#' @param vars.use Names of the variables.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
prepare_ggplot_alluvial_plot <- function(data,
vars.use){
items <- length(vars.use)
`%>%` <- magrittr::`%>%`
assertthat::assert_that(items <= 10,
msg = paste0(add_cross(), crayon_body("Please provide, in between "),
crayon_key("first_group"),
crayon_body(", "),
crayon_key("middle_groups"),
crayon_body(" and "),
crayon_key("last_group"),
crayon_body(" only up to "),
crayon_key("ten"),
crayon_body("different unique elements.")))
if (items == 2){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]]))
} else if (items == 3){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]]))
} else if (items == 4){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]]))
} else if (items == 5){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]]))
} else if (items == 6){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]]))
} else if (items == 7){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]]))
} else if (items == 8) {
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]]))
} else if (items == 9){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]],
axis9 = data[[vars.use[9]]]))
} else if (items == 10){
p <- data %>%
ggplot2::ggplot(mapping = ggplot2::aes(y = data$n,
axis1 = data[[vars.use[1]]],
axis2 = data[[vars.use[2]]],
axis3 = data[[vars.use[3]]],
axis4 = data[[vars.use[4]]],
axis5 = data[[vars.use[5]]],
axis6 = data[[vars.use[6]]],
axis7 = data[[vars.use[7]]],
axis8 = data[[vars.use[8]]],
axis9 = data[[vars.use[9]]],
axis10 = data[[vars.use[10]]]))
}
return(p)
}
#' Helper for axis.text.x.angle.
#'
#' @param angle Angle of rotation.
#' @param flip Whether the plot if flipped or not.
#'
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_axis_parameters <- function(angle,
flip){
if (isTRUE(flip)){
if (angle == 0){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
} else if (angle == 45){
out <- list("angle" = angle,
"hjust" = 1,
"vjust" = 1)
} else if (angle == 90){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
}
} else if (base::isFALSE(flip)){
if (angle == 0){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0)
} else if (angle == 45){
out <- list("angle" = angle,
"hjust" = 1,
"vjust" = 1)
} else if (angle == 90){
out <- list("angle" = angle,
"hjust" = 0.5,
"vjust" = 0.5)
}
}
return(out)
}
#' Compute UMAP layers.
#'
#' @param sample TBD
#' @param labels TBD
#' @param pt.size TBD
#' @param dot.size TBD
#' @param alpha TBD
#' @param na.value TBD
#' @param border.density TBD
#' @param border.size TBD
#' @param border.color TBD
#' @param raster TBD
#' @param raster.dpi TBD
#' @param reduction TBD
#' @param group.by TBD
#' @param split.by TBD
#' @param n TBD
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_umap_layer <- function(sample,
labels,
pt.size,
dot.size = 7.5,
alpha = 1,
na.value = "grey75",
border.density = 1,
border.size,
border.color,
raster = FALSE,
raster.dpi = 1024,
reduction = "umap",
group.by = NULL,
split.by = NULL,
n = 100,
skip.density = FALSE) {
`%>%` <- magrittr::`%>%`
embeddings <- Seurat::Embeddings(sample,
reduction = reduction)[, labels, drop = FALSE] %>%
as.data.frame()
colnames(embeddings) <- c("x", "y")
# Code adapted from: https://slowkow.com/notes/ggplot2-color-by-density/
# Licensed under: CC BY-SA (compatible with GPL-3).
# Author: Kamil Slowikowski - https://slowkow.com/
# Obtain density.
if (base::isFALSE(skip.density)){
density <- MASS::kde2d(x = embeddings$x,
y = embeddings$y,
n = n)
# Find the intervals.
x.intervals <- findInterval(embeddings$x, density$x)
y.intervals <- findInterval(embeddings$y, density$y)
# Generate density vector to add to metadata.
interval_matrix <- cbind(x.intervals, y.intervals)
density_vector <- density$z[interval_matrix]
embeddings$density <- density_vector
}
# Add the group.by and split.by layers.
if (!is.null(group.by)){
embeddings <- embeddings %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::left_join(y = sample@meta.data %>%
dplyr::select(dplyr::all_of(c(group.by))) %>%
tibble::rownames_to_column(var = "cell"),
by = "cell") %>%
tibble::column_to_rownames(var = "cell")
colnames(embeddings) <- c(colnames(embeddings)[seq(1, (length(colnames(embeddings)) - 1))], "group.by")
if (base::isFALSE(skip.density)){
density.center.group.by <- embeddings %>%
dplyr::select(dplyr::all_of(c("x", "y", "group.by", "density"))) %>%
dplyr::group_by(.data$group.by) %>%
dplyr::mutate("filt_x_up" = stats::quantile(.data$x, 0.66),
"filt_x_down" = stats::quantile(.data$x, 0.33),
"filt_y_up" = stats::quantile(.data$y, 0.66),
"filt_y_down" = stats::quantile(.data$y, 0.33)) %>%
dplyr::filter(.data$x >= .data$filt_x_down & .data$x <= .data$filt_x_up,
.data$y >= .data$filt_y_down & .data$y <= .data$filt_y_up) %>%
dplyr::summarize("x" = mean(.data$x),
"y" = mean(.data$y))
}
}
if (!is.null(split.by)){
embeddings <- embeddings %>%
tibble::rownames_to_column(var = "cell") %>%
dplyr::left_join(y = sample@meta.data %>%
dplyr::select(dplyr::all_of(c(split.by))) %>%
tibble::rownames_to_column(var = "cell"),
by = "cell") %>%
tibble::column_to_rownames(var = "cell")
colnames(embeddings) <- c(colnames(embeddings)[seq(1, (length(colnames(embeddings)) - 1))], "split.by")
}
# Apply filtering criteria:
if (base::isFALSE(skip.density)){
embeddings <- embeddings %>%
dplyr::filter(.data$density <= stats::quantile(embeddings$density, border.density))
}
# Generate base layer.
if (base::isFALSE(raster)){
base_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
colour = border.color,
size = pt.size * border.size,
show.legend = FALSE,
na.rm = TRUE)
} else {
base_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = border.color,
size = pt.size * border.size,
stroke = pt.size / 2,
show.legend = FALSE,
pointsize = pt.size * border.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
# Generate NA layer.
if (base::isFALSE(raster)){
na_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
colour = na.value,
size = pt.size,
show.legend = FALSE,
na.rm = TRUE)
} else {
na_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = na.value,
size = pt.size,
stroke = pt.size / 2,
show.legend = FALSE,
pointsize = pt.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
# Generate center points layer.
out <- list()
if (!is.null(group.by) & base::isFALSE(skip.density)){
# Generate colored based layer.
if (base::isFALSE(raster)){
color_layer <- ggplot2::geom_point(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
color = "white",
shape = 21,
alpha = alpha,
size = (pt.size * border.size) + 4,
stroke = 0,
show.legend = TRUE,
na.rm = TRUE)
} else {
color_layer <- scattermore::geom_scattermore(data = embeddings,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
size = (pt.size * border.size) + 4,
alpha = alpha,
stroke = pt.size / 2,
show.legend = TRUE,
pointsize = pt.size * border.size,
pixels = c(raster.dpi, raster.dpi),
na.rm = TRUE)
}
out[["color_layer"]] <- color_layer
center_layer_2 <- ggplot2::geom_point(data = density.center.group.by,
mapping = ggplot2::aes(x = .data$x,
y = .data$y),
color = "black",
size = pt.size * dot.size)
center_layer <- ggplot2::geom_point(data = density.center.group.by,
mapping = ggplot2::aes(x = .data$x,
y = .data$y,
fill = .data$group.by),
color = "white",
shape = 21,
size = pt.size * (dot.size - 2),
stroke = 1.5)
center_layers <- list("center_layer_2" = center_layer_2,
"center_layer_1" = center_layer)
out[["center_layers"]] <- center_layers
}
out[["base_layer"]] <- base_layer
out[["na_layer"]] <- na_layer
out[["embeddings"]] <- embeddings
return(out)
}
#
#
#' Duplicate secondary categorical axis.
#' From: https://github.com/tidyverse/ggplot2/issues/3171
#' @param label_trans Labels to send to the secondary axis.
#' @param ... Other
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
guide_axis_label_trans <- function(label_trans = identity, ...) {
axis_guide <- ggplot2::guide_axis(...)
axis_guide$label_trans <- rlang::as_function(label_trans)
class(axis_guide) <- c("guide_axis_trans", class(axis_guide))
axis_guide
}
#' Handle axis theme parameters
#'
#' @param flip TBD
#' @param counter TBD
#' @param group.by TBD
#' @param group TBD
#' @param xlab TBD
#' @param ylab TBD
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
handle_axis <- function(flip,
counter,
group.by,
group,
axis.text.x.angle,
plot.title.face,
plot.subtitle.face,
plot.caption.face,
axis.title.face,
axis.text.face,
legend.title.face,
legend.text.face){
# Set axis theme parameters.
if (base::isFALSE(flip)){
# Strips
if (counter == length(group.by)){
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_text(face = "bold", color = "black")
legend.position <- "none"
} else if (counter == 1) {
legend.position <- "bottom"
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
} else {
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
legend.position <- "none"
}
if (counter == 1){
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.ticks.y.left <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(face = axis.text.face, color = "black")
axis.text.y.left <- ggplot2::element_blank()
if (length(group.by) > 1){
axis.title.x.top <- ggplot2::element_blank()
axis.title.x.bottom <- ggplot2::element_blank()
} else {
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
vjust = 0.5,
hjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
}
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
hjust = 0.5,
vjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
} else {
axis.ticks.x.bottom <- ggplot2::element_blank()
axis.ticks.x.top <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.ticks.y.left <- ggplot2::element_blank()
axis.text.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(face = axis.text.face, color = "black")
axis.text.y.left <- ggplot2::element_blank()
if (length(group.by) > 1){
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
vjust = 0.5,
hjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
} else {
axis.title.x.top <- ggplot2::element_blank()
axis.title.x.bottom <- ggplot2::element_blank()
}
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
hjust = 0.5,
vjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
}
} else {
# Strips and legend.
if (counter == 1){
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_text(face = "bold", color = "black")
legend.position <- "none"
} else if (counter == length(group.by)){
legend.position <- "right"
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
} else {
strip.background <- ggplot2::element_blank()
strip.clip <- "off"
strip.text <- ggplot2::element_blank()
legend.position <- "none"
}
if (counter == 1){
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
hjust = 0.5,
vjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
if (length(group.by) == 1){
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(color = "black", face = axis.text.face)
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
vjust = 0.5,
hjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
} else {
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_blank()
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 90,
vjust = 0.5,
hjust = 0.5)
axis.title.y.right <- ggplot2::element_blank()
}
} else {
axis.ticks.x.bottom <- ggplot2::element_line(color = "black")
axis.ticks.x.top <- ggplot2::element_blank()
axis.text.x.bottom <- ggplot2::element_text(face = axis.text.face, color = "black",
angle = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["angle"]],
hjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["hjust"]],
vjust = get_axis_parameters(angle = axis.text.x.angle, flip = FALSE)[["vjust"]])
axis.text.x.top <- ggplot2::element_blank()
axis.title.x.top <- ggplot2::element_text(face = axis.title.face, color = "black",
angle = 0,
hjust = 0.5,
vjust = 0.5)
axis.title.x.bottom <- ggplot2::element_blank()
if (length(group.by) == counter){
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_line(color = "black")
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_text(color = "black", face = axis.text.face)
axis.title.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_blank()
} else {
axis.ticks.y.left <- ggplot2::element_blank()
axis.ticks.y.right <- ggplot2::element_blank()
axis.text.y.left <- ggplot2::element_blank()
axis.text.y.right <- ggplot2::element_blank()
axis.title.y.left <- ggplot2::element_blank()
axis.title.y.right <- ggplot2::element_blank()
}
}
}
out_list <- list("axis.ticks.x.top" = axis.ticks.x.top,
"axis.ticks.x.bottom" = axis.ticks.x.bottom,
"axis.ticks.y.left" = axis.ticks.y.left,
"axis.ticks.y.right" = axis.ticks.y.right,
"axis.text.x.bottom" = axis.text.x.bottom,
"axis.text.x.top" = axis.text.x.top,
"axis.text.y.left" = axis.text.y.left,
"axis.text.y.right" = axis.text.y.right,
"axis.title.x.bottom" = axis.title.x.bottom,
"axis.title.x.top" = axis.title.x.top,
"axis.title.y.left" = axis.title.y.left,
"axix.title.y.right" = axis.title.y.right,
"strip.background" = strip.background,
"strip.clip" = strip.clip,
"strip.text" = strip.text,
"legend.position" = legend.position)
return(out_list)
}
#' Generate a list of colors that will be used for metadata plots.
#'
#' @return None
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
get_SCpubr_colors <- function(){
colors <- c("#457b9d",
"#b5838d",
"#d4a276",
"#31572c",
"#354f52",
"#006d77",
"#bcb8b1",
"#d88c9a",
"#d8315b",
"#ee6c4d",
"#0c5460",
"#065a60",
"#d6ce93",
"#A88D21",
"#9a8c98",
"#6c757d",
"#00afb9",
"#38a3a5",
"#adc178",
"#bfd7b5")
return(colors)
}
#' Check the group.by parameter
#'
#' @param sample Seurat object.
#' @param group.by group.by parameter.
#' @param is.heatmap Whether the function computes a heatmap.
#'
#' @return The Seurat object.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_group_by <- function(sample,
group.by,
is.heatmap){
group.by.return <- NULL
if (is.null(group.by)){
assertthat::assert_that(!("Groups" %in% colnames(sample@meta.data)),
msg = paste0(add_cross(), crayon_body("Please, make sure you provide a value for "),
crayon_key("group.by"),
crayon_body(". The metadata column "),
crayon_key("Groups"),
crayon_body(" is used instead, but there is already such column in your metadata.")))
sample@meta.data[, "Groups"] <- sample@active.ident
group.by <- "Groups"
}
for (group in group.by){
assertthat::assert_that(group %in% colnames(sample@meta.data),
msg = paste0(add_cross(), crayon_body("The value provided to "),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(" is not part of the Seurat object "),
crayon_key("meta.data"),
crayon_body(".")))
assertthat::assert_that(class(sample@meta.data[, group]) %in% c("character", "factor"),
msg = paste0(add_cross(), crayon_body("The value provided to"),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(" is not a "),
crayon_key("character"),
crayon_body( "or "),
crayon_key("factor"),
crayon_body(" column in the sample"),
crayon_key("metadata of the Seurat object"),
crayon_body(".")))
if (isTRUE(is.heatmap)){
assertthat::assert_that(sum(is.na(sample@meta.data[, group])) == 0,
msg = paste0(add_warning(), crayon_body("Found "),
crayon_key("NAs"),
crayon_body(" in the metadata variable provided to "),
crayon_key(paste0("group.by (", group, " | defaults to Seurat::Idents(sample) if NULL)")),
crayon_body(". Please remove them before running the function.")))
}
group.by.return <- append(group.by.return, group)
}
return(list("sample" = sample,
"group.by" = group.by.return))
}
#' Temporal fix for DimPlots/FeaturePlots when using Assay5 and split.by
#'
#' @param sample Seurat object.
#' @param assay assay to use.
#'
#' @return The Seurat object.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
check_Assay5 <- function(sample,
assay = Seurat::DefaultAssay(sample)){
if (isTRUE(methods::is(sample@assays[[assay]], "Assay5"))){
suppressWarnings(sample@assays[[assay]] <- methods::as(sample@assays[[assay]], "Assay"))
}
return(sample)
}
#' Handles the generation of continuous color palettes for the plots.
#'
#' @param name Name of the palette.
#' @param use_viridis Whether it is a viridis palette or not.
#' @param direction Direction of the color scale.
#' @param enforce_symmetry Whether it is a diverging palette or not.
#'
#' @return The colors to use.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
compute_continuous_palette <- function(name = "YlGnBu",
use_viridis = FALSE,
direction = ifelse(isTRUE(use_viridis), -1, 1),
enforce_symmetry = FALSE){
light_end <- "grey95"
dark_end <- "grey5"
if (base::isFALSE(enforce_symmetry)){
if (base::isFALSE(getOption("SCpubr.ColorPaletteEnds"))){
if (isTRUE(use_viridis)){
if (direction == 1){
colors <- c(viridis::viridis(n = 9, direction = direction, option = name))
} else if (direction == -1){
colors <- c(viridis::viridis(n = 9, direction = direction, option = name))
}
} else if (isFALSE(use_viridis)){
if (direction == 1){
colors <- c(RColorBrewer::brewer.pal(n = 9, name = name))
} else if (direction == -1){
colors <- c(rev(RColorBrewer::brewer.pal(n = 9, name = name)))
}
}
} else {
if (isTRUE(use_viridis)){
if (direction == 1){
colors <- c(dark_end, viridis::viridis(n = 9, direction = direction, option = name), light_end)
} else if (direction == -1){
colors <- c(light_end, viridis::viridis(n = 9, direction = direction, option = name), dark_end)
}
} else if (isFALSE(use_viridis)){
if (direction == 1){
colors <- c(light_end, RColorBrewer::brewer.pal(n = 9, name = name), dark_end)
} else if (direction == -1){
colors <- c(dark_end, rev(RColorBrewer::brewer.pal(n = 9, name = name)), light_end)
}
}
}
} else {
if (direction == 1){
colors <- RColorBrewer::brewer.pal(n = 11, name = name)
} else if (direction == -1){
colors <- rev(RColorBrewer::brewer.pal(n = 11, name = name))
}
}
return(colors)
}
#' Normalizes a continuous variable to comprise it between 0 to 1.
#'
#' @param x Continuous variable.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
zero_one_norm <- function(x){
y <- (x - min(x, na.rm = TRUE)) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))
return(y)
}
#' Normalizes a continuous variable to comprise it between -1 to 1.
#'
#' @param x Continuous variable.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
one_one_norm <- function(x){
y <- 2 * ((x - min(x, na.rm = TRUE)) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))) - 1
return(y)
}
#' Normalizes a continuous variable to comprise it between a to b.
#'
#' @param x Continuous variable.
#' @param a,b Ends of the range.
#'
#' @return A normalized variable.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
range_norm <- function(x, a, b){
y <- (b - a) * ((x - (min(x, na.rm = TRUE))) / (max(x, na.rm = TRUE) - min(x, na.rm = TRUE))) + a
return(y)
}
#' Rounds up a vector of percentages to ensure they add up to 100.
#'
#' First, truncates the values and keeps the truncated values and discarded decimals stored.
#' Then, it orders the discarded decimals and adds a unit to the correspondent truncated value
#' until the summ of truncated values reaches 100.
#'
#' For exclusive use in do_WafflePlot().
#'
#' @param x Data Frame of frequencies.
#' @param group.by The grouping variable used.
#'
#' @return A rounded up vector of percentages.
#' @noRd
#' @examples
#' \donttest{
#' TBD
#' }
round_percent <- function(x,
group.by){
# Generate named vector of freqs.
x <- as.data.frame(x)
names.use <- x[, group.by]
freqs <- x$freq
names(freqs) <- names.use
# Get trunctaed values and the removed percentages.
trimmed <- trunc(freqs)
cut.percent <- rev(sort(freqs - trimmed))
# Now, order the removed percentages and, in descending order, add a unit to the trimmed values until they add up to 100.
index <- 0
while(sum(trimmed) != 100){
index <- index + 1
trimmed[names(trimmed[index])] <- trimmed[index] + 1
}
# Return the new vector of rounded percentages.
return(trimmed)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.