R/helper-functions.R
In kueckelj/SPATA: A Toolbox for Spatial Gene Expression Analysis
Defines functions
hlpr_filter_trend
hlpr_name_models
hlpr_summarize_residuals
hlpr_add_residuals
hlpr_add_models
hlpr_widen_trajectory_df
hlpr_vector_projection
hlpr_summarize_trajectory_df
hlpr_subset_across
hlpr_smooth_shiny
hlpr_smooth
hlpr_one_distinct
hlpr_normalize_vctr
hlpr_normalize_imap
hlpr_labs_add_on
hlpr_image_add_on2
hlpr_image_add_on
hlpr_gene_set_name
hlpr_compile_trajectory
hlpr_compare_samples
hlpr_assign
Documented in
hlpr_add_models
hlpr_add_residuals
hlpr_assign
hlpr_compare_samples
hlpr_compile_trajectory
hlpr_filter_trend
hlpr_gene_set_name
hlpr_image_add_on
hlpr_image_add_on2
hlpr_labs_add_on
hlpr_name_models
hlpr_normalize_imap
hlpr_normalize_vctr
hlpr_one_distinct
hlpr_smooth
hlpr_smooth_shiny
hlpr_subset_across
hlpr_summarize_residuals
hlpr_summarize_trajectory_df
hlpr_vector_projection
hlpr_widen_trajectory_df
#' @import SingleCellExperiment
#'
NULL
#' Assign objects into the global environment
#'
#' @param assign Logical.
#' @param object The object to be assigned.
#' @param name The name of the assigned object.
#'
hlpr_assign <- function(assign, object, name){
if(base::isTRUE(assign)){
base::assign(
x = name,
value = object,
envir = .GlobalEnv
)
}
}
#' @title Compare samples within an object
#'
#' @description Checks whether the sample column in \code{df}
#' complies with the sample names of the provided object.
#'
#' @param object A valid spata-object.
#' @param df A data.frame
#' @param messages The message vector that is generated by the function in which
#' \code{hlpr_compare_samples()} is called in.
#'
#' @return Updated message vector.
#'
#' @details This function is to be used within the \code{SPATA::validateSpataObject()}-
#' functions. It expands the message-vector that is being generated by the calling
#' function and returns it.
hlpr_compare_samples <- function(object, df, messages){
df_samples <- stringr::str_c(base::unique(df$sample), collapse = ", ") %>% base::sort()
o_samples <- stringr::str_c(samples(object), collapse = ", ") %>% base::sort()
if(!base::identical(df_samples, o_samples)){
feedback <-
stringr::str_c("Inavlid samples in column 'sample'.:",
"\n In coordinates: ", df_samples,
"\n In object: ", o_samples,
sep = "")
messages <-
base::append(x = messages,
values = feedback)
}
return(messages)
}
#' @title Compiles a trajectory data.frame
#'
#' @param segment_trajectory_df A data.frame specifying each segment of the whole
#' trajectory with variables \code{x, y, xend, yend}.
#' @param trajectory_width Numeric value that determines the width of the
#' trajectory.
#' @inherit check_sample params
#'
#' @return A data.frame containing the variables \emph{barcodes, sample, x, y}
#' as well as
#' \itemize{
#' \item{\emph{projection_length}: indicating the position of every barcode-spot
#' with respect to the direction of the trajectory-part. The higher the barcode-spots
#' value is the farther away it is from the starting point of the trajectory-part
#' it belongs to. }
#' \item{\emph{trajectory_part}: indicating the part of the trajectory the barcode-spot
#' belongs to.}
#' }
#'
#' @export
hlpr_compile_trajectory <- function(segment_trajectory_df,
trajectory_width,
object,
sample){
validation(object)
all_trajectories_list <- list()
for(i in 1:base::nrow(segment_trajectory_df)){
# One dimensional part ----------------------------------------------------
trajectory_vector_df <- segment_trajectory_df[i,1:4]
start_point <- as.numeric(trajectory_vector_df[1:2])
end_point <- as.numeric(trajectory_vector_df[3:4])
trajectory_vec <- end_point - start_point
# factor with which to compute the width vector
trajectory_magnitude <- base::sqrt((trajectory_vec[1])^2 + (trajectory_vec[2])^2)
trajectory_factor <- trajectory_width / trajectory_magnitude
# orthogonal trajectory vector
orth_trajectory_vec <- (c(-trajectory_vec[2], trajectory_vec[1]) * trajectory_factor)
# Two dimensional part ----------------------------------------------------
# determine trajectory frame points 'tfps' making up the square that embraces
# the points
tfp1.1 <- start_point + orth_trajectory_vec
tfp1.2 <- start_point - orth_trajectory_vec
tfp2.1 <- end_point - orth_trajectory_vec
tfp2.2 <- end_point + orth_trajectory_vec
trajectory_frame <-
data.frame(
x = c(tfp1.1[1], tfp1.2[1], tfp2.1[1], tfp2.2[1]),
y = c(tfp1.1[2], tfp1.2[2], tfp2.1[2], tfp2.2[2])
)
# calculate every point of interests projection on the trajectory vector using 'vector projection' on a local
# coordinate system 'lcs' to sort the points according to the trajectories direction
sample_coords <-
getCoordinates(object = object, of_sample = sample)
lcs <- data.frame(
x = c(tfp1.1[1], tfp1.1[1]),
y = c(tfp1.1[2], tfp1.1[2]),
xend = c(tfp2.2[1], tfp1.2[1]),
yend = c(tfp2.2[2], tfp1.2[2]),
id = c("local length axis", "local width axis")
)
positions <- sp::point.in.polygon(point.x = sample_coords$x,
point.y = sample_coords$y,
pol.x = trajectory_frame$x,
pol.y = trajectory_frame$y)
# Data wrangling part -----------------------------------------------------
# points of interest data.frame
points_of_interest <-
sample_coords %>%
dplyr::mutate(position = positions) %>%
dplyr::filter(position != 0) %>% # filter only those that fall in the trajectory frame
dplyr::select(-position) %>%
dplyr::group_by(barcodes) %>%
dplyr::mutate(projection_length = hlpr_vector_projection(lcs = lcs, x, y),
trajectory_part = stringr::str_c("Part", i, sep = " ")) %>%
dplyr::arrange(projection_length) %>% # arrange barcodes according to their projection value
dplyr::ungroup()
all_trajectories_list[[i]] <- points_of_interest
}
compiled_trajectory_df <- base::do.call(base::rbind, all_trajectories_list)
return(compiled_trajectory_df)
}
#' Removes the class part of a gene set string
#'
#' @param string Gene sets as a character vector
#'
#' @return Gene set name
#'
hlpr_gene_set_name <- function(string){
stringr::str_remove(string = string, pattern = "^.+?_")
}
#' @title Provides the image as ggplot background
#'
#' @inherit check_sample params
#' @param image Image input.
#' @param display_image Logical value.
#'
#' @return Either null or a ggplot2::geom_annotation_raster
#'
#' @export
hlpr_image_add_on <- function(image){
if(!base::is.null(image)){
if(!"Image" %in% base::class(image)){
base::warning("Argument 'image' is neither NULL nor an object of class 'Image'. ")
image_add_on <- NULL
} else {
image_raster <- grDevices::as.raster(image)
image_info <-
magick::image_read(image_raster) %>%
magick::image_info()
image_flipped <-
magick::image_read(image_raster) %>%
magick::image_flip()
image_add_on <-
ggplot2::annotation_raster(raster = image_flipped,
xmin = 0, ymin = 0,
xmax = image_info$width,
ymax = image_info$height)
}
}
}
#' @rdname hlpr_image_add_on
#' @export
hlpr_image_add_on2 <- function(object, display_image, of_sample){
# set up background
if(base::isTRUE(display_image)){
image_raster <-
image(object, of_sample) %>%
grDevices::as.raster()
img_info <-
image_raster %>%
magick::image_read() %>%
magick::image_info()
st_image <-
image_raster %>%
magick::image_read() %>%
magick::image_flip()
image_add_on <-
ggplot2::annotation_raster(raster = st_image,
xmin = 0, ymin = 0,
xmax = img_info$width,
ymax = img_info$height)
} else {
image_add_on <- NULL
}
}
#' @title Return customized ggplot:labs()
#'
#' @description Helper function
#'
#' @param input The color_to argument
#' @param input_str Title-prefix. Should be one of \emph{'Genes:', 'Gene set:'} or \code{'Feature:'}.
#' @param color_str Legend title
#' @param display_title Logical. If set to FALSE only the legend-title will be specified.
#'
#' @return A customized \code{ggplot2::labs()}-function.
#' @export
hlpr_labs_add_on <- function(input,
input_str,
color_str,
display_title){
if(base::isTRUE(display_title)){
if(base::length(input) > 5){
input <- c(input[1:5], stringr::str_c("... +", (base::length(input)-5), sep = " "))
}
input_clpsd <- stringr::str_c(input, collapse = ", ")
plot_title <- stringr::str_c(input_str, input_clpsd, sep = " ")
base::return(ggplot2::labs(title = plot_title, color = color_str))
} else {
base::return(ggplot2::labs(color = color_str))
}
}
#' @title Normalize gene or gene set values
#'
#' @description Helper function to use within \code{purrr::imap()}
#'
#' @param variable The variable to normalize (if matches requirements).
#' @param var_name The name of the variable to smooth.
#' @param verbose Logical
#' @param aspect Gene or Gene set
#' @param subset A character vector of variable names that are to be normalized
#' @param pb An R6 progress bar object.
#'
#' @return A normalized variable (data.frame within \code{purrr::imap()})
#' @export
hlpr_normalize_imap <- function(variable,
var_name,
aspect,
subset){
if(!base::is.numeric(variable) | !var_name %in% subset){
base::return(variable)
} else if(base::all(variable == 0)){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c(aspect, var_name, "contains only 0s. Returning NULL.", sep = " "))
base::return(NULL)
} else if(base::length(base::unique(variable)) == 1){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c(aspect, var_name, "is uniformly expressed. Returning NULL.", sep = " "))
base::return(NULL)
} else {
# normalize variable
res <-
(variable - base::min(variable)) /
(base::max(variable) - base::min(variable))
if(!base::any(base::is.na(res))){
base::return(res)
} else {
base::warning(stringr::str_c(aspect, var_name, "normalization resulted in NaNs. Returning NULL.", sep = " "))
base::return(NULL)
}
}
}
#' @inherit hlpr_normalize_imap params title
#'
#' @return A normalized variable
#' @export
hlpr_normalize_vctr <- function(variable){
res <-
(variable - base::min(variable)) /
(base::max(variable) - base::min(variable))
if(base::any(base::is.na(res))){
base::return(variable)
} else {
base::return(res)
}
}
#' @title Number of distinct values equal to 1?
#'
#' @description Helper function to use within purrr::map_lgl. Returns
#' TRUE if the gene row of the provided rna assay is uniformly expressed.
#'
#' @param x Input variable.
#' @param rna_assay Expression matrix
#' @param pb Progress bar object
#'
#' @return
#' @export
#'
hlpr_one_distinct <- function(x, rna_assay, pb = NULL, verbose = TRUE){
if(!base::is.null(pb)){pb$tick()}
res <- dplyr::n_distinct(rna_assay[x,]) == 1
base::return(res)
}
#' @title Smooth variables spatially
#'
#' @description Helper function to use within \code{purrr::imap()}
#'
#' @param variable The variable to smooth
#' @param var_name Name of the variable to smooth
#' @param coords_df Data.frame that contains x and y coordinates
#' @param verbose Logical
#' @param smooth_span Span to smooth with
#' @param aspect Gene or Gene set
#' @param subset Vector of variable names to smooth
#' @param pb A progress-bar or NULL.
#'
#' @return Smoothed variable (data.frame within \code{purrr::imap()})
#' @export
hlpr_smooth <- function(variable,
var_name,
coords_df,
smooth_span,
aspect,
subset,
pb = NULL){
if(!base::is.null(pb)){
pb$tick()
}
data <-
base::cbind(variable, coords_df[, c("x", "y")]) %>%
magrittr::set_colnames(value = c("rv", "x", "y"))
if(!var_name %in% subset){
base::return(variable)
} else if(!base::is.numeric(data$rv)){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning("Skip smoothing of ", aspect, " '", var_name, "' as it is of class '", base::class(dplyr::pull(data, rv)), "'.")
base::return(variable)
} else if(base::any(base::is.na(data$rv)) |
base::any(base::is.nan(data$rv))|
base::any(base::is.infinite(data$rv))){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c("Skip smoothing of", aspect, var_name, "as it contains NaNs or infinites.", sep = " "))
base::return(variable)
} else {
if(base::isTRUE(verbose)){
if(var_name == "mean_genes"){
var_name <- "average"
}
}
model <- stats::loess(formula = rv ~ x * y, data = data, span = smooth_span)
return(stats::predict(object = model))
}
}
#' @title Smooth variable spatially in mini-shiny-apps
#'
#' @description Helper function to use independently (or in a pipe)
#'
#' @inherit hlpr_smooth params
#'
#' @return Data.frame with the smoothed variable specified in \code{variable}.
#'
hlpr_smooth_shiny <- function(variable,
coords_df,
smooth_span){
base::colnames(coords_df)[base::which(base::colnames(coords_df) == variable)] <- "response_variable"
if(base::is.numeric(coords_df$response_variable)){
model <- stats::loess(formula = response_variable ~ x * y, span = smooth_span, data = coords_df)
smoothed_df_prel <-
broom::augment(model) %>%
dplyr::select(x, y, .fitted) %>%
magrittr::set_colnames(value = c("x", "y", variable))
selected_df <- dplyr::select(coords_df, -c("x", "y", "response_variable"))
smoothed_df <-
base::cbind(smoothed_df_prel, selected_df) %>%
dplyr::select(barcodes, sample, x, y, dplyr::everything()) %>%
as.data.frame()
# if coords_df derived from trajectory analysis
if("trajectory_order" %in% base::colnames(coords_df)){
smoothed_df$trajectory_order <- coords_df$trajectory_order
}
if(base::nrow(smoothed_df) == base::nrow(coords_df)){
return(smoothed_df)
} else {
shiny::showNotification(ui = "Smoothing failed. Return original values.",
type = "warning")
return(coords_df)
}
} else {
shiny::showNotification(ui = "Can not smooth features that aren't of class 'numeric'. Skip smoothing.",
type = "warning")
base::colnames(coords_df)[base::which(base::colnames(coords_df) == "response_variable")] <- variable
return(coords_df)
}
}
#' Subset the across-variables
#'
#' @description Checks across and across_subset input and if at least one
#' of the across_subset values exists filters the data accordingly.
#'
#' @param data A data.frame that contains the variable specified in \code{across}.
#' @param across Character value. Denotes the discrete variable in the data.frame
#' across which something is to be analyzed or displayed.
#' @param across_subset Character vector. The groups of interest that the \code{across}-
#' variable contains.
#'
#' @return A filtered data.frame, informative messages or an error.
#' @export
#'
hlpr_subset_across <- function(data, across, across_subset){
if(base::is.null(across_subset)){
base::return(data)
} else {
data[[across]] <- confuns::unfactor(data[[across]])
ref.against <-
glue::glue("'{across}'-variable of the specified spata-object") %>%
base::as.character()
across_subset <-
confuns::check_vector(
input = across_subset,
against = base::unique(data[[across]]),
verbose = TRUE,
ref.input = "'across_subset'",
ref.against = ref.against) %>%
base::as.character()
data <- dplyr::filter(.data = data, !!rlang::sym(across) %in% {{across_subset}})
base::return(data)
}
}
#' @title Join and summarize compiled trajectory data.frames
#'
#' @description Joins a compiled trajectory data.frame with
#' the desired information and summarizes those.
#'
#' @inherit check_object params
#' @inherit check_compiled_trajectory_df params
#' @inherit check_variables params
#' @inherit check_method params
#' @inherit verbose params
#' @inherit normalize params
#' @param accuracy Numeric. Given to \code{accuracy}-argument of
#' \code{plyr::round_any()}. Determines how many barcode-spots will be summarized
#' as one sub-trajectory-part.
#'
#' @details Initially the compiled trajectory data.frame of the specified trajectory
#' is joined with the respective input of variables via \code{joinWithVariables()}.
#'
#' The argument \code{accuracy} refers to the amount of which the barcode-spots of the
#' given trajectory will be summarized with regards to the trajectory's direction:
#' The amount of \code{accuracy} and the previously specified 'trajectory width' in \code{createTrajectories()}
#' determine the length and width of the sub-rectangles in which the rectangle the
#' trajectory embraces are splitted and in which all barcode-spots are binned.
#' Via \code{dplyr::summarize()} the variable-means of every sub-rectangle are calculated.
#' These mean-values are then arranged according to the trajectory's direction.
#'
#' Eventually the data.frame is shifted via \code{tidyr::pivot_longer()} to a data.frame in which
#' every observation refers to the mean-value of one of the specified variable-elements (e.g. a specified
#' gene set) of the particular sub-rectangle. The returned data.frame contains the following variables:
#'
#' \itemize{
#' \item{\emph{trajectory_part}: Character. Specifies the trajectory's sub-part of the observation. (Negligible if there is
#' only one trajectory part.)}
#' \item{\emph{trajectory_part_order}: Numeric. Indicates the order within the trajectory-part. (Negligible if there is
#' only one trajectory part.)}
#' \item{\emph{trajectory_order}: Numeric. Indicates the order within the whole trajectory.}
#' \item{\emph{gene_sets, genes or features}: Character. The respective gene sets, gene or feature the value refers to.}
#' \item{\emph{values}: Numeric. The actual summarized values.}}
#'
#' @export
hlpr_summarize_trajectory_df <- function(object,
ctdf,
accuracy = 5,
variables,
method_gs = "mean",
verbose = TRUE,
normalize = FALSE){
# 1. Control --------------------------------------------------------------
# lazy check
check_object(object)
check_compiled_trajectory_df(ctdf = ctdf)
stopifnot(base::is.numeric(accuracy))
stopifnot(base::is.character(variables))
stopifnot(base::is.logical(verbose))
# adjusting check
variables <- check_variables(variables = variables,
all_features = getFeatureNames(object, c("numeric", "integer")),
all_gene_sets = getGeneSets(object),
all_genes = getGenes(object),
max_slots = 3,
max_length = Inf)
if("features" %in% base::names(variables)){
variables[["features"]] <- check_features(object = object,
features = variables[["features"]],
valid_classes = c("numeric", "integer"))
}
# -----
# 2. Summarize and join compiled trajectory data.frame --------------------
# join data.frame with variables
joined_df <-
dplyr::mutate(.data = ctdf,
order_binned = plyr::round_any(x = projection_length,
accuracy = accuracy,
f = base::floor)) %>%
joinWithVariables(object = object,
spata_df = .,
variables = variables,
method_gs = method_gs,
average_genes = FALSE,
smooth = FALSE,
normalize = FALSE,
verbose = verbose)
# keep only variables that were successfully joined
variables <- base::unlist(variables, use.names = FALSE)
variables <- variables[variables %in% base::colnames(joined_df)]
# summarize data.frame
if(base::isTRUE(verbose)){base::message("Summarizing trajectory data.frame.")}
summarized_df <-
dplyr::group_by(.data = joined_df, trajectory_part, order_binned) %>%
dplyr::summarise(dplyr::across(.cols = dplyr::all_of(x = variables),
.fns = ~ mean(., na.rm = TRUE)),
.groups = "drop_last") %>%
dplyr::mutate(trajectory_part_order = dplyr::row_number()) %>%
dplyr::ungroup() %>%
dplyr::mutate(trajectory_order = dplyr::row_number()) %>%
dplyr::select(-order_binned) %>%
tidyr::pivot_longer(cols = dplyr::all_of(x = variables),
names_to = "variables",
values_to = "values")
if(base::isTRUE(normalize)){
if(base::isTRUE(verbose)){base::message("Normalizing values.")}
summarized_df <-
dplyr::group_by(.data = summarized_df, variables) %>%
dplyr::mutate(values = confuns::normalize(x = values)) %>%
dplyr::ungroup()
}
if(base::isTRUE(verbose)){base::message("Done.")}
# -----
base::return(summarized_df)
}
#' @title Perform vector projection
#'
#' @description Helper function for trajectory-analysis to use within
#' \code{dplyr::mutate()}. Performs vector-projection with a spatial position
#' and a local coordinates system to arrange the barcodes that fall into a
#' trajectory square according to the trajectory direction.
#'
#' @param lcs A data.frame specifying the local coordinates system with variables
#' \code{x, y, xend, yend} and the observations \emph{local length axis} and
#' \emph{local width axis}.
#' @param x_coordinate x-coordinate
#' @param y_coordinate y-coordinate
#'
#' @return The projected length.
#'
#' @export
hlpr_vector_projection <- function(lcs, x_coordinate, y_coordinate){
# vector from point of interest to origin of local coord system: 'vto'
vto <- c((x_coordinate - lcs$x[1]), (y_coordinate - lcs$y[1]))
# define local length axis (= relocated trajectory): 'lla'
lla <- c((lcs$xend[1] - lcs$x[1]), (lcs$yend[1] - lcs$y[1]))
# define lambda coefficient
lambda <-
((vto[1] * lla[1]) + (vto[2] * lla[2])) / base::sqrt((lla[1])^2 + (lla[2])^2)^2
# projecting vector on length axis
pv <- lambda * (lla)
# compute the length of the projected vector
res <- base::sqrt((pv[1])^2 + (pv[2])^2)
base::return(res)
}
#' @title Widen trajectory data.frame
#'
#' @param stdf A summarized trajectory data.frame - output
#' from \code{hlpr_summarize_trajectory_df()}.
#' @param variable Character value. The variable of \code{stdf}:
#' \emph{'gene_sets', 'genes'} or \emph{'features'}.
#'
#'
#' @return A widened data.frame in which each every observation is a
#' trajectory and every variable describes the value of the trajectory
#' at a specific position.
#'
#' @export
#'
hlpr_widen_trajectory_df <- function(stdf,
variable){
tidyr::pivot_wider(data = tdf,
id_cols = dplyr::all_of(c("trajectory_order", variable)),
names_from = dplyr::all_of(c("trajectory_part", "trajectory_order")),
values_from = "values")
}
#' @title Helper functions for trajectory ranking
#'
#' @description Functions to use within \code{purrr::map()} again in \code{dplyr::mutate()} in order to
#' create a nested ranked trajectory data.frame.
#'
#' \itemize{
#' \item{\code{hlpr_add_models()}: Returns a data.frame of variables corresponding to
#' mathematical curves.}
#' \item{\code{hlpr_add_residuals(): Calculates the residuals of the variable \emph{values} with respect
#' to each mathematical curve.}}
#' \item{\code{hlpr_summarise_residuals(): Calculates the area under the curve for every residual in order to
#' access the fit of the respective expression trend to the fitted curve.}}}
#'
#' @param df A data.frame.
#'
#' @return If used within \code{purrr::map()} a list of data.frames.
#' @export
#'
hlpr_add_models <- function(df, custom_fit = NULL){
dplyr::transmute(.data = df,
trajectory_order = trajectory_order,
p_one_peak = confuns::fit_curve(trajectory_order, "one_peak"),
p_one_peak_rev = confuns::fit_curve(trajectory_order, "one_peak", rev = TRUE),
p_two_peaks = confuns::fit_curve(trajectory_order, "two_peaks"),
p_two_peaks_rev = confuns::fit_curve(trajectory_order, "two_peaks", rev = TRUE),
p_gradient_desc = confuns::fit_curve(trajectory_order, "gradient"),
p_gradient_asc = confuns::fit_curve(trajectory_order, "gradient", rev = TRUE),
p_log_asc = confuns::fit_curve(trajectory_order, "log"),
p_log_desc = confuns::fit_curve(trajectory_order, "log", rev = TRUE),
p_lin_asc = confuns::fit_curve(trajectory_order, "linear"),
p_lin_desc = confuns::fit_curve(trajectory_order, "linear", rev = TRUE),
p_sin = confuns::fit_curve(trajectory_order, "sinus"),
p_sin_rev = confuns::fit_curve(trajectory_order, "sinus", rev = TRUE),
p_early_peak = confuns::fit_curve(trajectory_order, "early_peak"),
p_late_peak = confuns::fit_curve(trajectory_order, "late_peak"),
p_custom = custom_fit
)
}
#' @rdname hlpr_add_models
#' @export
hlpr_add_residuals <- function(df, pb = NULL, custom_fit = NULL){
if(!base::is.null(pb)){
pb$tick()
}
dplyr::transmute(.data = df,
trajectory_order = trajectory_order,
p_one_peak = (values - confuns::fit_curve(trajectory_order, "one_peak"))^2,
p_one_peak_rev = (values - confuns::fit_curve(trajectory_order, "one_peak", rev = TRUE))^2,
p_two_peaks = (values - confuns::fit_curve(trajectory_order, "two_peaks"))^2,
p_two_peaks_rev = (values - confuns::fit_curve(trajectory_order, "two_peaks", rev = TRUE))^2,
p_gradient_desc = (values - confuns::fit_curve(trajectory_order, "gradient"))^2,
p_gradient_asc = (values - confuns::fit_curve(trajectory_order, "gradient", rev = TRUE))^2,
p_log_asc = (values - confuns::fit_curve(trajectory_order, "log"))^2,
p_log_desc = (values - confuns::fit_curve(trajectory_order, "log", rev = TRUE))^2,
p_lin_asc = (values - confuns::fit_curve(trajectory_order, "linear"))^2,
p_lin_desc = (values - confuns::fit_curve(trajectory_order, "linear", rev = TRUE))^2,
p_sin = (values - confuns::fit_curve(trajectory_order, "sinus"))^2,
p_sin_rev = (values - confuns::fit_curve(trajectory_order, "sinus", rev = TRUE))^2,
p_early_peak = (values - confuns::fit_curve(trajectory_order, "early_peak"))^2,
p_late_peak = (values - confuns::fit_curve(trajectory_order, "late_peak"))^2)
}
#' @rdname hlpr_add_models
#' @export
hlpr_summarize_residuals <- function(df, pb = NULL){
if(!base::is.null(pb)){
pb$tick()
}
purrr::map_dfc(.x = dplyr::select(df, -trajectory_order),
.f = function(y){
pracma::trapz(x = df$trajectory_order, y = y)
})
}
#' @rdname hlpr_add_models
#' @export
hlpr_name_models <- function(names){
stringr::str_replace_all(
string = names,
pattern = c(
"gradient_desc" = "Gradient descending",
"gradient_asc" = "Gradient ascending",
"lin_desc" = "Linear descending",
"lin_asc" = "Linear ascending",
"log_desc" = "Logarithmic descending",
"log_asc" = "Logarithmic ascending",
"one_peak_rev" = "One peak (reversed)",
"one_peak" = "One peak",
"sin_rev" = "Sinus (reversed)",
"sin" = "Sinus",
"two_peaks_rev" = "Two peaks (reversed)",
"two_peaks" = "Two peaks",
"early_peak" = "Early peak",
"late_peak" = "Late peak",
"custom_fit" = "Custom fit"
)
)
}
#' @rdname hlpr_add_models
#' @export
hlpr_filter_trend <- function(atdf, limit, poi){
check_atdf(atdf)
confuns::is_value(x = limit, mode = "numeric", ref = "limit")
res <-
dplyr::filter(.data = atdf, pattern %in% poi & auc <= limit) %>%
dplyr::pull(var = variables) %>% base::unique()
if(base::length(res) == 0){
base::stop(glue::glue("No trajectory-trends of pattern '{stringr::str_c(poi, collapse = ', ')}' found with auc lower than {limit}."))
} else {
base::return(res)
}
}
kueckelj/SPATA documentation built on March 22, 2022, 9:59 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 hlpr_filter_trend hlpr_name_models hlpr_summarize_residuals hlpr_add_residuals hlpr_add_models hlpr_widen_trajectory_df hlpr_vector_projection hlpr_summarize_trajectory_df hlpr_subset_across hlpr_smooth_shiny hlpr_smooth hlpr_one_distinct hlpr_normalize_vctr hlpr_normalize_imap hlpr_labs_add_on hlpr_image_add_on2 hlpr_image_add_on hlpr_gene_set_name hlpr_compile_trajectory hlpr_compare_samples hlpr_assign
Documented in hlpr_add_models hlpr_add_residuals hlpr_assign hlpr_compare_samples hlpr_compile_trajectory hlpr_filter_trend hlpr_gene_set_name hlpr_image_add_on hlpr_image_add_on2 hlpr_labs_add_on hlpr_name_models hlpr_normalize_imap hlpr_normalize_vctr hlpr_one_distinct hlpr_smooth hlpr_smooth_shiny hlpr_subset_across hlpr_summarize_residuals hlpr_summarize_trajectory_df hlpr_vector_projection hlpr_widen_trajectory_df
#' @import SingleCellExperiment
#'
NULL
#' Assign objects into the global environment
#'
#' @param assign Logical.
#' @param object The object to be assigned.
#' @param name The name of the assigned object.
#'
hlpr_assign <- function(assign, object, name){
if(base::isTRUE(assign)){
base::assign(
x = name,
value = object,
envir = .GlobalEnv
)
}
}
#' @title Compare samples within an object
#'
#' @description Checks whether the sample column in \code{df}
#' complies with the sample names of the provided object.
#'
#' @param object A valid spata-object.
#' @param df A data.frame
#' @param messages The message vector that is generated by the function in which
#' \code{hlpr_compare_samples()} is called in.
#'
#' @return Updated message vector.
#'
#' @details This function is to be used within the \code{SPATA::validateSpataObject()}-
#' functions. It expands the message-vector that is being generated by the calling
#' function and returns it.
hlpr_compare_samples <- function(object, df, messages){
df_samples <- stringr::str_c(base::unique(df$sample), collapse = ", ") %>% base::sort()
o_samples <- stringr::str_c(samples(object), collapse = ", ") %>% base::sort()
if(!base::identical(df_samples, o_samples)){
feedback <-
stringr::str_c("Inavlid samples in column 'sample'.:",
"\n In coordinates: ", df_samples,
"\n In object: ", o_samples,
sep = "")
messages <-
base::append(x = messages,
values = feedback)
}
return(messages)
}
#' @title Compiles a trajectory data.frame
#'
#' @param segment_trajectory_df A data.frame specifying each segment of the whole
#' trajectory with variables \code{x, y, xend, yend}.
#' @param trajectory_width Numeric value that determines the width of the
#' trajectory.
#' @inherit check_sample params
#'
#' @return A data.frame containing the variables \emph{barcodes, sample, x, y}
#' as well as
#' \itemize{
#' \item{\emph{projection_length}: indicating the position of every barcode-spot
#' with respect to the direction of the trajectory-part. The higher the barcode-spots
#' value is the farther away it is from the starting point of the trajectory-part
#' it belongs to. }
#' \item{\emph{trajectory_part}: indicating the part of the trajectory the barcode-spot
#' belongs to.}
#' }
#'
#' @export
hlpr_compile_trajectory <- function(segment_trajectory_df,
trajectory_width,
object,
sample){
validation(object)
all_trajectories_list <- list()
for(i in 1:base::nrow(segment_trajectory_df)){
# One dimensional part ----------------------------------------------------
trajectory_vector_df <- segment_trajectory_df[i,1:4]
start_point <- as.numeric(trajectory_vector_df[1:2])
end_point <- as.numeric(trajectory_vector_df[3:4])
trajectory_vec <- end_point - start_point
# factor with which to compute the width vector
trajectory_magnitude <- base::sqrt((trajectory_vec[1])^2 + (trajectory_vec[2])^2)
trajectory_factor <- trajectory_width / trajectory_magnitude
# orthogonal trajectory vector
orth_trajectory_vec <- (c(-trajectory_vec[2], trajectory_vec[1]) * trajectory_factor)
# Two dimensional part ----------------------------------------------------
# determine trajectory frame points 'tfps' making up the square that embraces
# the points
tfp1.1 <- start_point + orth_trajectory_vec
tfp1.2 <- start_point - orth_trajectory_vec
tfp2.1 <- end_point - orth_trajectory_vec
tfp2.2 <- end_point + orth_trajectory_vec
trajectory_frame <-
data.frame(
x = c(tfp1.1[1], tfp1.2[1], tfp2.1[1], tfp2.2[1]),
y = c(tfp1.1[2], tfp1.2[2], tfp2.1[2], tfp2.2[2])
)
# calculate every point of interests projection on the trajectory vector using 'vector projection' on a local
# coordinate system 'lcs' to sort the points according to the trajectories direction
sample_coords <-
getCoordinates(object = object, of_sample = sample)
lcs <- data.frame(
x = c(tfp1.1[1], tfp1.1[1]),
y = c(tfp1.1[2], tfp1.1[2]),
xend = c(tfp2.2[1], tfp1.2[1]),
yend = c(tfp2.2[2], tfp1.2[2]),
id = c("local length axis", "local width axis")
)
positions <- sp::point.in.polygon(point.x = sample_coords$x,
point.y = sample_coords$y,
pol.x = trajectory_frame$x,
pol.y = trajectory_frame$y)
# Data wrangling part -----------------------------------------------------
# points of interest data.frame
points_of_interest <-
sample_coords %>%
dplyr::mutate(position = positions) %>%
dplyr::filter(position != 0) %>% # filter only those that fall in the trajectory frame
dplyr::select(-position) %>%
dplyr::group_by(barcodes) %>%
dplyr::mutate(projection_length = hlpr_vector_projection(lcs = lcs, x, y),
trajectory_part = stringr::str_c("Part", i, sep = " ")) %>%
dplyr::arrange(projection_length) %>% # arrange barcodes according to their projection value
dplyr::ungroup()
all_trajectories_list[[i]] <- points_of_interest
}
compiled_trajectory_df <- base::do.call(base::rbind, all_trajectories_list)
return(compiled_trajectory_df)
}
#' Removes the class part of a gene set string
#'
#' @param string Gene sets as a character vector
#'
#' @return Gene set name
#'
hlpr_gene_set_name <- function(string){
stringr::str_remove(string = string, pattern = "^.+?_")
}
#' @title Provides the image as ggplot background
#'
#' @inherit check_sample params
#' @param image Image input.
#' @param display_image Logical value.
#'
#' @return Either null or a ggplot2::geom_annotation_raster
#'
#' @export
hlpr_image_add_on <- function(image){
if(!base::is.null(image)){
if(!"Image" %in% base::class(image)){
base::warning("Argument 'image' is neither NULL nor an object of class 'Image'. ")
image_add_on <- NULL
} else {
image_raster <- grDevices::as.raster(image)
image_info <-
magick::image_read(image_raster) %>%
magick::image_info()
image_flipped <-
magick::image_read(image_raster) %>%
magick::image_flip()
image_add_on <-
ggplot2::annotation_raster(raster = image_flipped,
xmin = 0, ymin = 0,
xmax = image_info$width,
ymax = image_info$height)
}
}
}
#' @rdname hlpr_image_add_on
#' @export
hlpr_image_add_on2 <- function(object, display_image, of_sample){
# set up background
if(base::isTRUE(display_image)){
image_raster <-
image(object, of_sample) %>%
grDevices::as.raster()
img_info <-
image_raster %>%
magick::image_read() %>%
magick::image_info()
st_image <-
image_raster %>%
magick::image_read() %>%
magick::image_flip()
image_add_on <-
ggplot2::annotation_raster(raster = st_image,
xmin = 0, ymin = 0,
xmax = img_info$width,
ymax = img_info$height)
} else {
image_add_on <- NULL
}
}
#' @title Return customized ggplot:labs()
#'
#' @description Helper function
#'
#' @param input The color_to argument
#' @param input_str Title-prefix. Should be one of \emph{'Genes:', 'Gene set:'} or \code{'Feature:'}.
#' @param color_str Legend title
#' @param display_title Logical. If set to FALSE only the legend-title will be specified.
#'
#' @return A customized \code{ggplot2::labs()}-function.
#' @export
hlpr_labs_add_on <- function(input,
input_str,
color_str,
display_title){
if(base::isTRUE(display_title)){
if(base::length(input) > 5){
input <- c(input[1:5], stringr::str_c("... +", (base::length(input)-5), sep = " "))
}
input_clpsd <- stringr::str_c(input, collapse = ", ")
plot_title <- stringr::str_c(input_str, input_clpsd, sep = " ")
base::return(ggplot2::labs(title = plot_title, color = color_str))
} else {
base::return(ggplot2::labs(color = color_str))
}
}
#' @title Normalize gene or gene set values
#'
#' @description Helper function to use within \code{purrr::imap()}
#'
#' @param variable The variable to normalize (if matches requirements).
#' @param var_name The name of the variable to smooth.
#' @param verbose Logical
#' @param aspect Gene or Gene set
#' @param subset A character vector of variable names that are to be normalized
#' @param pb An R6 progress bar object.
#'
#' @return A normalized variable (data.frame within \code{purrr::imap()})
#' @export
hlpr_normalize_imap <- function(variable,
var_name,
aspect,
subset){
if(!base::is.numeric(variable) | !var_name %in% subset){
base::return(variable)
} else if(base::all(variable == 0)){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c(aspect, var_name, "contains only 0s. Returning NULL.", sep = " "))
base::return(NULL)
} else if(base::length(base::unique(variable)) == 1){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c(aspect, var_name, "is uniformly expressed. Returning NULL.", sep = " "))
base::return(NULL)
} else {
# normalize variable
res <-
(variable - base::min(variable)) /
(base::max(variable) - base::min(variable))
if(!base::any(base::is.na(res))){
base::return(res)
} else {
base::warning(stringr::str_c(aspect, var_name, "normalization resulted in NaNs. Returning NULL.", sep = " "))
base::return(NULL)
}
}
}
#' @inherit hlpr_normalize_imap params title
#'
#' @return A normalized variable
#' @export
hlpr_normalize_vctr <- function(variable){
res <-
(variable - base::min(variable)) /
(base::max(variable) - base::min(variable))
if(base::any(base::is.na(res))){
base::return(variable)
} else {
base::return(res)
}
}
#' @title Number of distinct values equal to 1?
#'
#' @description Helper function to use within purrr::map_lgl. Returns
#' TRUE if the gene row of the provided rna assay is uniformly expressed.
#'
#' @param x Input variable.
#' @param rna_assay Expression matrix
#' @param pb Progress bar object
#'
#' @return
#' @export
#'
hlpr_one_distinct <- function(x, rna_assay, pb = NULL, verbose = TRUE){
if(!base::is.null(pb)){pb$tick()}
res <- dplyr::n_distinct(rna_assay[x,]) == 1
base::return(res)
}
#' @title Smooth variables spatially
#'
#' @description Helper function to use within \code{purrr::imap()}
#'
#' @param variable The variable to smooth
#' @param var_name Name of the variable to smooth
#' @param coords_df Data.frame that contains x and y coordinates
#' @param verbose Logical
#' @param smooth_span Span to smooth with
#' @param aspect Gene or Gene set
#' @param subset Vector of variable names to smooth
#' @param pb A progress-bar or NULL.
#'
#' @return Smoothed variable (data.frame within \code{purrr::imap()})
#' @export
hlpr_smooth <- function(variable,
var_name,
coords_df,
smooth_span,
aspect,
subset,
pb = NULL){
if(!base::is.null(pb)){
pb$tick()
}
data <-
base::cbind(variable, coords_df[, c("x", "y")]) %>%
magrittr::set_colnames(value = c("rv", "x", "y"))
if(!var_name %in% subset){
base::return(variable)
} else if(!base::is.numeric(data$rv)){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning("Skip smoothing of ", aspect, " '", var_name, "' as it is of class '", base::class(dplyr::pull(data, rv)), "'.")
base::return(variable)
} else if(base::any(base::is.na(data$rv)) |
base::any(base::is.nan(data$rv))|
base::any(base::is.infinite(data$rv))){
if(var_name == "mean_genes"){
var_name <- "average"
}
base::warning(stringr::str_c("Skip smoothing of", aspect, var_name, "as it contains NaNs or infinites.", sep = " "))
base::return(variable)
} else {
if(base::isTRUE(verbose)){
if(var_name == "mean_genes"){
var_name <- "average"
}
}
model <- stats::loess(formula = rv ~ x * y, data = data, span = smooth_span)
return(stats::predict(object = model))
}
}
#' @title Smooth variable spatially in mini-shiny-apps
#'
#' @description Helper function to use independently (or in a pipe)
#'
#' @inherit hlpr_smooth params
#'
#' @return Data.frame with the smoothed variable specified in \code{variable}.
#'
hlpr_smooth_shiny <- function(variable,
coords_df,
smooth_span){
base::colnames(coords_df)[base::which(base::colnames(coords_df) == variable)] <- "response_variable"
if(base::is.numeric(coords_df$response_variable)){
model <- stats::loess(formula = response_variable ~ x * y, span = smooth_span, data = coords_df)
smoothed_df_prel <-
broom::augment(model) %>%
dplyr::select(x, y, .fitted) %>%
magrittr::set_colnames(value = c("x", "y", variable))
selected_df <- dplyr::select(coords_df, -c("x", "y", "response_variable"))
smoothed_df <-
base::cbind(smoothed_df_prel, selected_df) %>%
dplyr::select(barcodes, sample, x, y, dplyr::everything()) %>%
as.data.frame()
# if coords_df derived from trajectory analysis
if("trajectory_order" %in% base::colnames(coords_df)){
smoothed_df$trajectory_order <- coords_df$trajectory_order
}
if(base::nrow(smoothed_df) == base::nrow(coords_df)){
return(smoothed_df)
} else {
shiny::showNotification(ui = "Smoothing failed. Return original values.",
type = "warning")
return(coords_df)
}
} else {
shiny::showNotification(ui = "Can not smooth features that aren't of class 'numeric'. Skip smoothing.",
type = "warning")
base::colnames(coords_df)[base::which(base::colnames(coords_df) == "response_variable")] <- variable
return(coords_df)
}
}
#' Subset the across-variables
#'
#' @description Checks across and across_subset input and if at least one
#' of the across_subset values exists filters the data accordingly.
#'
#' @param data A data.frame that contains the variable specified in \code{across}.
#' @param across Character value. Denotes the discrete variable in the data.frame
#' across which something is to be analyzed or displayed.
#' @param across_subset Character vector. The groups of interest that the \code{across}-
#' variable contains.
#'
#' @return A filtered data.frame, informative messages or an error.
#' @export
#'
hlpr_subset_across <- function(data, across, across_subset){
if(base::is.null(across_subset)){
base::return(data)
} else {
data[[across]] <- confuns::unfactor(data[[across]])
ref.against <-
glue::glue("'{across}'-variable of the specified spata-object") %>%
base::as.character()
across_subset <-
confuns::check_vector(
input = across_subset,
against = base::unique(data[[across]]),
verbose = TRUE,
ref.input = "'across_subset'",
ref.against = ref.against) %>%
base::as.character()
data <- dplyr::filter(.data = data, !!rlang::sym(across) %in% {{across_subset}})
base::return(data)
}
}
#' @title Join and summarize compiled trajectory data.frames
#'
#' @description Joins a compiled trajectory data.frame with
#' the desired information and summarizes those.
#'
#' @inherit check_object params
#' @inherit check_compiled_trajectory_df params
#' @inherit check_variables params
#' @inherit check_method params
#' @inherit verbose params
#' @inherit normalize params
#' @param accuracy Numeric. Given to \code{accuracy}-argument of
#' \code{plyr::round_any()}. Determines how many barcode-spots will be summarized
#' as one sub-trajectory-part.
#'
#' @details Initially the compiled trajectory data.frame of the specified trajectory
#' is joined with the respective input of variables via \code{joinWithVariables()}.
#'
#' The argument \code{accuracy} refers to the amount of which the barcode-spots of the
#' given trajectory will be summarized with regards to the trajectory's direction:
#' The amount of \code{accuracy} and the previously specified 'trajectory width' in \code{createTrajectories()}
#' determine the length and width of the sub-rectangles in which the rectangle the
#' trajectory embraces are splitted and in which all barcode-spots are binned.
#' Via \code{dplyr::summarize()} the variable-means of every sub-rectangle are calculated.
#' These mean-values are then arranged according to the trajectory's direction.
#'
#' Eventually the data.frame is shifted via \code{tidyr::pivot_longer()} to a data.frame in which
#' every observation refers to the mean-value of one of the specified variable-elements (e.g. a specified
#' gene set) of the particular sub-rectangle. The returned data.frame contains the following variables:
#'
#' \itemize{
#' \item{\emph{trajectory_part}: Character. Specifies the trajectory's sub-part of the observation. (Negligible if there is
#' only one trajectory part.)}
#' \item{\emph{trajectory_part_order}: Numeric. Indicates the order within the trajectory-part. (Negligible if there is
#' only one trajectory part.)}
#' \item{\emph{trajectory_order}: Numeric. Indicates the order within the whole trajectory.}
#' \item{\emph{gene_sets, genes or features}: Character. The respective gene sets, gene or feature the value refers to.}
#' \item{\emph{values}: Numeric. The actual summarized values.}}
#'
#' @export
hlpr_summarize_trajectory_df <- function(object,
ctdf,
accuracy = 5,
variables,
method_gs = "mean",
verbose = TRUE,
normalize = FALSE){
# 1. Control --------------------------------------------------------------
# lazy check
check_object(object)
check_compiled_trajectory_df(ctdf = ctdf)
stopifnot(base::is.numeric(accuracy))
stopifnot(base::is.character(variables))
stopifnot(base::is.logical(verbose))
# adjusting check
variables <- check_variables(variables = variables,
all_features = getFeatureNames(object, c("numeric", "integer")),
all_gene_sets = getGeneSets(object),
all_genes = getGenes(object),
max_slots = 3,
max_length = Inf)
if("features" %in% base::names(variables)){
variables[["features"]] <- check_features(object = object,
features = variables[["features"]],
valid_classes = c("numeric", "integer"))
}
# -----
# 2. Summarize and join compiled trajectory data.frame --------------------
# join data.frame with variables
joined_df <-
dplyr::mutate(.data = ctdf,
order_binned = plyr::round_any(x = projection_length,
accuracy = accuracy,
f = base::floor)) %>%
joinWithVariables(object = object,
spata_df = .,
variables = variables,
method_gs = method_gs,
average_genes = FALSE,
smooth = FALSE,
normalize = FALSE,
verbose = verbose)
# keep only variables that were successfully joined
variables <- base::unlist(variables, use.names = FALSE)
variables <- variables[variables %in% base::colnames(joined_df)]
# summarize data.frame
if(base::isTRUE(verbose)){base::message("Summarizing trajectory data.frame.")}
summarized_df <-
dplyr::group_by(.data = joined_df, trajectory_part, order_binned) %>%
dplyr::summarise(dplyr::across(.cols = dplyr::all_of(x = variables),
.fns = ~ mean(., na.rm = TRUE)),
.groups = "drop_last") %>%
dplyr::mutate(trajectory_part_order = dplyr::row_number()) %>%
dplyr::ungroup() %>%
dplyr::mutate(trajectory_order = dplyr::row_number()) %>%
dplyr::select(-order_binned) %>%
tidyr::pivot_longer(cols = dplyr::all_of(x = variables),
names_to = "variables",
values_to = "values")
if(base::isTRUE(normalize)){
if(base::isTRUE(verbose)){base::message("Normalizing values.")}
summarized_df <-
dplyr::group_by(.data = summarized_df, variables) %>%
dplyr::mutate(values = confuns::normalize(x = values)) %>%
dplyr::ungroup()
}
if(base::isTRUE(verbose)){base::message("Done.")}
# -----
base::return(summarized_df)
}
#' @title Perform vector projection
#'
#' @description Helper function for trajectory-analysis to use within
#' \code{dplyr::mutate()}. Performs vector-projection with a spatial position
#' and a local coordinates system to arrange the barcodes that fall into a
#' trajectory square according to the trajectory direction.
#'
#' @param lcs A data.frame specifying the local coordinates system with variables
#' \code{x, y, xend, yend} and the observations \emph{local length axis} and
#' \emph{local width axis}.
#' @param x_coordinate x-coordinate
#' @param y_coordinate y-coordinate
#'
#' @return The projected length.
#'
#' @export
hlpr_vector_projection <- function(lcs, x_coordinate, y_coordinate){
# vector from point of interest to origin of local coord system: 'vto'
vto <- c((x_coordinate - lcs$x[1]), (y_coordinate - lcs$y[1]))
# define local length axis (= relocated trajectory): 'lla'
lla <- c((lcs$xend[1] - lcs$x[1]), (lcs$yend[1] - lcs$y[1]))
# define lambda coefficient
lambda <-
((vto[1] * lla[1]) + (vto[2] * lla[2])) / base::sqrt((lla[1])^2 + (lla[2])^2)^2
# projecting vector on length axis
pv <- lambda * (lla)
# compute the length of the projected vector
res <- base::sqrt((pv[1])^2 + (pv[2])^2)
base::return(res)
}
#' @title Widen trajectory data.frame
#'
#' @param stdf A summarized trajectory data.frame - output
#' from \code{hlpr_summarize_trajectory_df()}.
#' @param variable Character value. The variable of \code{stdf}:
#' \emph{'gene_sets', 'genes'} or \emph{'features'}.
#'
#'
#' @return A widened data.frame in which each every observation is a
#' trajectory and every variable describes the value of the trajectory
#' at a specific position.
#'
#' @export
#'
hlpr_widen_trajectory_df <- function(stdf,
variable){
tidyr::pivot_wider(data = tdf,
id_cols = dplyr::all_of(c("trajectory_order", variable)),
names_from = dplyr::all_of(c("trajectory_part", "trajectory_order")),
values_from = "values")
}
#' @title Helper functions for trajectory ranking
#'
#' @description Functions to use within \code{purrr::map()} again in \code{dplyr::mutate()} in order to
#' create a nested ranked trajectory data.frame.
#'
#' \itemize{
#' \item{\code{hlpr_add_models()}: Returns a data.frame of variables corresponding to
#' mathematical curves.}
#' \item{\code{hlpr_add_residuals(): Calculates the residuals of the variable \emph{values} with respect
#' to each mathematical curve.}}
#' \item{\code{hlpr_summarise_residuals(): Calculates the area under the curve for every residual in order to
#' access the fit of the respective expression trend to the fitted curve.}}}
#'
#' @param df A data.frame.
#'
#' @return If used within \code{purrr::map()} a list of data.frames.
#' @export
#'
hlpr_add_models <- function(df, custom_fit = NULL){
dplyr::transmute(.data = df,
trajectory_order = trajectory_order,
p_one_peak = confuns::fit_curve(trajectory_order, "one_peak"),
p_one_peak_rev = confuns::fit_curve(trajectory_order, "one_peak", rev = TRUE),
p_two_peaks = confuns::fit_curve(trajectory_order, "two_peaks"),
p_two_peaks_rev = confuns::fit_curve(trajectory_order, "two_peaks", rev = TRUE),
p_gradient_desc = confuns::fit_curve(trajectory_order, "gradient"),
p_gradient_asc = confuns::fit_curve(trajectory_order, "gradient", rev = TRUE),
p_log_asc = confuns::fit_curve(trajectory_order, "log"),
p_log_desc = confuns::fit_curve(trajectory_order, "log", rev = TRUE),
p_lin_asc = confuns::fit_curve(trajectory_order, "linear"),
p_lin_desc = confuns::fit_curve(trajectory_order, "linear", rev = TRUE),
p_sin = confuns::fit_curve(trajectory_order, "sinus"),
p_sin_rev = confuns::fit_curve(trajectory_order, "sinus", rev = TRUE),
p_early_peak = confuns::fit_curve(trajectory_order, "early_peak"),
p_late_peak = confuns::fit_curve(trajectory_order, "late_peak"),
p_custom = custom_fit
)
}
#' @rdname hlpr_add_models
#' @export
hlpr_add_residuals <- function(df, pb = NULL, custom_fit = NULL){
if(!base::is.null(pb)){
pb$tick()
}
dplyr::transmute(.data = df,
trajectory_order = trajectory_order,
p_one_peak = (values - confuns::fit_curve(trajectory_order, "one_peak"))^2,
p_one_peak_rev = (values - confuns::fit_curve(trajectory_order, "one_peak", rev = TRUE))^2,
p_two_peaks = (values - confuns::fit_curve(trajectory_order, "two_peaks"))^2,
p_two_peaks_rev = (values - confuns::fit_curve(trajectory_order, "two_peaks", rev = TRUE))^2,
p_gradient_desc = (values - confuns::fit_curve(trajectory_order, "gradient"))^2,
p_gradient_asc = (values - confuns::fit_curve(trajectory_order, "gradient", rev = TRUE))^2,
p_log_asc = (values - confuns::fit_curve(trajectory_order, "log"))^2,
p_log_desc = (values - confuns::fit_curve(trajectory_order, "log", rev = TRUE))^2,
p_lin_asc = (values - confuns::fit_curve(trajectory_order, "linear"))^2,
p_lin_desc = (values - confuns::fit_curve(trajectory_order, "linear", rev = TRUE))^2,
p_sin = (values - confuns::fit_curve(trajectory_order, "sinus"))^2,
p_sin_rev = (values - confuns::fit_curve(trajectory_order, "sinus", rev = TRUE))^2,
p_early_peak = (values - confuns::fit_curve(trajectory_order, "early_peak"))^2,
p_late_peak = (values - confuns::fit_curve(trajectory_order, "late_peak"))^2)
}
#' @rdname hlpr_add_models
#' @export
hlpr_summarize_residuals <- function(df, pb = NULL){
if(!base::is.null(pb)){
pb$tick()
}
purrr::map_dfc(.x = dplyr::select(df, -trajectory_order),
.f = function(y){
pracma::trapz(x = df$trajectory_order, y = y)
})
}
#' @rdname hlpr_add_models
#' @export
hlpr_name_models <- function(names){
stringr::str_replace_all(
string = names,
pattern = c(
"gradient_desc" = "Gradient descending",
"gradient_asc" = "Gradient ascending",
"lin_desc" = "Linear descending",
"lin_asc" = "Linear ascending",
"log_desc" = "Logarithmic descending",
"log_asc" = "Logarithmic ascending",
"one_peak_rev" = "One peak (reversed)",
"one_peak" = "One peak",
"sin_rev" = "Sinus (reversed)",
"sin" = "Sinus",
"two_peaks_rev" = "Two peaks (reversed)",
"two_peaks" = "Two peaks",
"early_peak" = "Early peak",
"late_peak" = "Late peak",
"custom_fit" = "Custom fit"
)
)
}
#' @rdname hlpr_add_models
#' @export
hlpr_filter_trend <- function(atdf, limit, poi){
check_atdf(atdf)
confuns::is_value(x = limit, mode = "numeric", ref = "limit")
res <-
dplyr::filter(.data = atdf, pattern %in% poi & auc <= limit) %>%
dplyr::pull(var = variables) %>% base::unique()
if(base::length(res) == 0){
base::stop(glue::glue("No trajectory-trends of pattern '{stringr::str_c(poi, collapse = ', ')}' found with auc lower than {limit}."))
} else {
base::return(res)
}
}
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.