# default* ----------------------------------------------------------------
#' @title Default observations geometry
#'
#' @description
#' Extracts the default ggplot2 geometry to visualize \link[=concept_observations]{observations}
#' in 2D space on surface plots.
#'
#' @inherit argument_dummy params
#'
#' @return Character value.
#'
#' @keywords internal
#'
<- (object){
platform <- (object)
(platform == "VisiumHD"){
out <- "tile"
} {
out <- "point"
}
(out)
}
# deprecated --------------------------------------------------------------
# functions to facilitate deprecating functions and/or arguments
deprecated <- (fn = , fdb_fn = "warning", ){
# which function is checked
fn_name <-
rlang::caller_call() %>%
rlang::call_name()
# in which function is it used
calling_fn <- rlang::caller_call(n = 2)
(!::(calling_fn)){
caller_fn <- rlang::call_name(calling_fn)
ref_caller <- glue::glue("( used by {caller_fn}() )")
} {
ref_caller <- ""
}
(::(fn)){
replaced_by <- depr_info$fns[fn_name]]
(::(replaced_by)){
msg <-
glue::glue(
"Function `{fn_name}()` is deprecated and will be deleted in the near future. Please use `{replaced_by}()` instead.{ref_caller}"
)
} {
msg <-
glue::glue(
"Function `{fn_name}()` is deprecated and will be deleted in the near future.{ref_caller}"
)
}
confuns::give_feedback(
msg = msg,
fdb.fn = fdb_fn,
with.time =
)
}
<- ()
args_named <- confuns::keep_named()
(::(args_named) >= 1){
# first check for fucntion specific deprecated args
fn_args_depr <- deprecatedArguments(opt = "function", fn_name = fn_name)
# get specific arguments
args_named_fn <- args_named[base::(args_named) %in% fn_args_depr]
# remove specific arguments from rest
args_named <- args_named!args_named %in% args_named_fn]
(old_arg_name ::(args_named_fn)){
new_arg_name <- depr_info"args_spec"]][fn_name]][old_arg_name]]
(::(new_arg_name)){
msg <-
glue::glue(
"In function `{fn_name}()`, argument `{old_arg_name}` is deprecated and no longer in use.{ref_caller}"
)
} {
msg <-
glue::glue(
"In function `{fn_name}()`, argument `{old_arg_name}` is deprecated. Please use argument `{new_arg_name}` instead.{ref_caller}"
)
ce <- rlang::caller_env()
::(x = new_arg_name, value = [old_arg_name]], envir = ce)
}
confuns::give_feedback(
msg = msg,
fdb.fn = fdb_fn,
with.time =
)
}
# second, check for generally deprecated args
args_named <- args_named[base::(args_named) %in% deprecatedArguments(opt = "generally")]
(old_arg_name ::(args_named)){
new_arg_name <- depr_info$[old_arg_name]]
(::(new_arg_name)){
msg <- glue::glue("Argument `{old_arg_name}` is deprecated and no longer in use.{ref_caller}")
} {
msg <-
glue::glue(
"Argument `{old_arg_name}` is deprecated. Please use argument `{new_arg_name}` instead.{ref_caller}"
)
ce <- rlang::caller_env()
::(x = new_arg_name, value = [old_arg_name]], envir = ce)
}
confuns::give_feedback(
msg = msg,
fdb.fn = fdb_fn,
with.time =
)
}
}
}
deprecatedArguments <- (opt = "generally", fn_name = ){
(opt == "generally"){
out <- depr_info"args"]] %>% ::()
} (opt == "function"){
out <- depr_info"args_spec"]][fn_name]] %>% ::()
}
(out)
}
#' @title Information about deprecated aspects
#'
#' @description Outputs a list of recently deprecated content as well
#' as what it was replaced by.
#'
#' @return List of three slots:
#' \itemize{
#' \item{fns:}{ A list of generally deprecated functions. Slot names are the functions that have been deprecated. Slot content is the name of the function it has been replaced by.}
#' \item{args:}{ A list of systematic argument renaming. Slot names are the argument names that have been deprecated. Slot content is the name of the argument the old one has been replaced by.}
#' \item{args_spec:}{ A list of function specific argument changes. Slot names are the function names. Slot content is a list organized as slot *args*.}
#' }
#'
#' If content is `NA` there is no replacement und the function/argument has been deleted and is no longer in use.
#'
#' @export
<- (){
depr_info
}
# dis ---------------------------------------------------------------------
#' @export
discardExpressionMatrix <- (){
deprecated(fn = , )
()
}
#' @keywords internal
#' @export
discard_uniform_variables <- (spata_df, variables, verbose = ){
confuns::give_feedback(
msg = "Identifying and discarding uniformly expressed variables.",
verbose = verbose
)
pb <- confuns::create_progress_bar(total = ::(variables))
<-
purrr::map_lgl(
.x = variables,
.f = (vname){
((verbose)){ pb$tick() }
(spata_df[vname]]) &
(dplyr::n_distinct(spata_df[vname]]) == 1)
}
)
n_rm <- ::()
confuns::give_feedback(
msg = glue::glue("Discarded {n_rm} variable(s) due to uniform expression."),
verbose = verbose
)
remove_vars <- variables[remove]
variables <- variables!variables %in% remove_vars]
spata_df <- dplyr::select(spata_df, -dplyr::all_of(remove_vars))
(spata_df)
}
#' @title Dissolve groups in a SPATA2 object
#'
#' @description This function dissolves specified groups in a [`SPATA2`] object by merging them into
#' the closest neighboring groups based on the pairwise distances
#' between \link[=concept_observations]{observations}.
#'
#' @inherit argument_dummy params
#' @param groups_dissolve A character vector specifying the names of the groups to be dissolved.
#' @param grouping_new A character string specifying the name for the new grouping variable.
#' If `NULL`, the original grouping variable will be updated. Default is `NULL`!
#'
#' @inherit update_dummy return
#'
#' @seealso [`createSpatialSegmentation()`]
#'
#' @details This function performs the following steps:
#' 1. Retrieves the metadata data frame from the [`SPATA2`] object.
#' 2. Checks if the specified grouping and groups to dissolve exist in the object.
#' 3. Computes the pairwise distances between all observations.
#' 4. Identifies the closest neighboring groups for the observations in the groups to be dissolved.
#' 5. Updates the grouping variable with the new group assignments.
#' 6. If `grouping_new` is provided, a new grouping variable is created; otherwise, the original grouping variable is updated.
#'
#' @examples
#'
#' library(SPATA2)
#' library(ggplot2)
#' library(patchwork)
#'
#' object <- loadExampleObject("UKF313T")
#'
#' # add example grouping
#' # this is a random grouping variable solely created for demonstrating the
#' # purpose of dissolveGroups()! It is not of any analytical value!
#' object <- addFeatures(object, feature_df = example_data$dissolve_groups)
#'
#' # note the many spots of class 'unnamed' surrounded by actual groups
#' plot_before <-
#' plotSurface(object, color_by = "histo_bad", pt_clrp = "uc", clrp_adjust = c("unnamed" = "black"))
#'
#' # show plot
#' plot_before
#'
#' # dissolve the group "unnamed"
#' object <-
#' dissolveGroups(
#' object = object,
#' grouping = "histo_bad",
#' groups_dissolve = "unnamed",
#' grouping_new = "histo_better"
#' )
#'
#' # spots of group 'unnamed' have been dissolved into their respective neighbor group
#' # use alpha (transparency) to highlight spots that used to of group "unnamed"
#' plot_afterwards <-
#' plotSurface(object, color_by = "histo_better", pt_clrp = "uc", alpha_by = "histo_alpha") +
#' scale_alpha_identity()
#'
#' # show plots
#' plot_before + plot_afterwards
#'
#' @export
<- (object,
,
groups_dissolve,
grouping_new = ){
confuns::check_one_of(
input = ,
against = (object)
)
confuns::check_one_of(
input = groups_dissolve,
against = (object, = )
)
mdf <- (object)
mdf$X_grouping1 <- mdf[grouping]]
mdf$X_grouping2 <- mdf[grouping]]
replacement_df <-
(object) %>%
compute_pairwise_distances() %>%
dplyr::left_join(y = mdf,("barcodes", "X_grouping1")], = ("barcodes1" = "barcodes")) %>%
dplyr::left_join(y = mdf,("barcodes", "X_grouping2")], = ("barcodes2" = "barcodes")) %>%
dplyr::(X_grouping1 %in% {{groups_dissolve}} & !X_grouping2 %in% {{groups_dissolve}}) %>%
dplyr::group_by(barcodes1) %>%
dplyr::slice_min(, n = 1, with_ties = ) %>%
dplyr::select(barcodes = barcodes1, X_grouping2)
mdf$X_grouping1 <-
mdf$X_grouping2 <-
old_levels <- ::(mdf[grouping]])
new_levels <- old_levels!old_levels %in% groups_dissolve]
mdf_new <-
dplyr::left_join(x = mdf, y = replacement_df, = "barcodes") %>%
dplyr::mutate(
{{}} := ::(!!rlang::sym()),
{{}} :=
dplyr::if_else(
= !!rlang::sym() %in% {{groups_dissolve}},
true = X_grouping2,
false = !!rlang::sym()
),
{{}} := ::(!!rlang::sym(), = new_levels)
) %>%
dplyr::select(barcodes, {{}})
(::(grouping_new)){
mdf_new[grouping_new]] <- mdf_new[grouping]]
mdf_new[grouping]] <-
}
object <- (object, feature_df = mdf_new, overwrite = )
returnSpataObject(object)
}
#' @title Distance to edge of tissue section
#'
#' @description Computes the distance from the border of a spatial annotation
#' to the **farest** data point of the tissue section it is located on.
#'
#' @inherit getSpatialAnnotation params
#' @param unit The output unit of the distance measure.
#'
#' @return Distance measure.
#'
#' @seealso [`whichTissueSection()`]
#'
#' @export
#'
<- (object, id = (object), = (object)){
section <- (object, id)
coords_df <-
(object, variables = "tissue_section") %>%
dplyr::(tissue_section == {{section}})
spat_ann_mtr <-
(object, id = id) %>%
dplyr::(section == {{section}}) %>%
dplyr::select(x, y) %>%
::()
tissue_mtr <-
(object, by_section = ) %>%
dplyr::(section == {{section}}) %>%
dplyr::select(x, y) %>%
::()
nn_out <-
RANN::nn2(
= spat_ann_mtr,
query = ::(coords_df,("x", "y")]),
searchtype = "priority",
k = 1
)
out <-
(input = ::(nn_out$nn.dists)*1.01, object = object, = )
(out)
}
# download ----------------------------------------------------------------
#' @title Download data from publications
#'
#' @description Downloads processed data as used in publications revolving
#' around SPATA2. See details for valid input options.
#'
#' @param pub Character value. The publication of interest.
#' @param id Character value. The id of the data object of interest.
#'
#' @return Depends argument input.
#'
#' @details The following data can be downloaded.
#'
#' From *Kueckelhaus et al., 2024* with `pub = 'Kueckelhaus_et_al_2024'`.
#'
#' \itemize{
#' \item{id = 'UKF313T'}{An object of class `SPATA2` containing human glioblastoma Visium data.}
#' \item{id = 'UKF269T'}{An object of class `SPATA2` containing human glioblastoma Visium data.}
#' \item{id = 'UKF265C'}{An object of class `SPATA2` containing human neocortex Visium data.}
#' \item{id = 'MCI_LMU'}{An object of class `SPATA2` containing injured mouse cortex Visium data.}
#' }
#'
#' @examples
#'
#' # download the processed SPATA2 object from sample UKF313T from Kueckelhaus et al., 2024.
#' objectT313 <- downloadFromPublication(pub = "kueckelhaus_et_al_2024", what = "UKF313T")
#'
#' @keywords internal
#'
<- (pub, ){
confuns::check_one_of(
input = pub,
against = ::(download_links)
)
confuns::check_one_of(
input = id,
against = ::(download_links[pub]])
)
link <- download_links[pub]][id]]"link"]]
# add code to downlaod
# create `download_links`
}
#' @inherit SPATAData::downloadSpataObject title description params return examples seealso
#' @inheritSection SPATAData::downloadSpataObject Google Drive Warning
#' @note Imported from the package `SPATAData`.
#' @importFrom SPATAData downloadSpataObject
#' @export
<- SPATAData::
#' @inherit SPATAData::downloadSpataObjects title description params return examples
#' @importFrom SPATAData downloadSpataObjects
#' @inheritSection SPATAData::downloadSpataObject Google Drive Warning
#' @export
<- SPATAData::
