Merge pull request #99 from lambdamoses/factory

Refactor *_join functions with function factory
stemangiola · Oct 22, 2023 · 326384e · 326384e
2 parents 6d7414d + 88b5d74
commit 326384e
Showing 1 changed file with 33 additions and 95 deletions.
diff --git a/R/dplyr_methods.R b/R/dplyr_methods.R
@@ -326,6 +326,35 @@ rowwise.SingleCellExperiment <- function(data, ...) {
         dplyr::rowwise(...)
 }
 
+.join_factory <- function(fun, change_x) {
+    function(x, y, 
+             by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) {
+
+        # Deprecation of special column names
+        .cols <- if (!is.null(by)) by else colnames(y)
+        if (is_sample_feature_deprecated_used(x, .cols)) {
+            x <- ping_old_special_column_into_metadata(x)
+        }
+        if (is(y, "DataFrame")) y <- as.data.frame(y)
+        z <- x |>
+            as_tibble() |>
+            fun(y, by=by, copy=copy, suffix=suffix, ...)
+
+        # If duplicated cells returns tibble
+        if (any(duplicated(z[[c_(x)$name]]))) {
+            message(duplicated_cell_names)
+            return(z)
+        }
+
+        # Otherwise return updated tidySingleCellExperiment
+        if (change_x)
+            new_obj <- x[, pull(z, c_(x)$name)]
+        else new_obj <- x
+        colData(new_obj) <- z |> as_meta_data(new_obj)
+        return(new_obj)
+    }
+}
+
 #' @name left_join
 #' @rdname left_join
 #' @inherit dplyr::left_join
@@ -348,29 +377,7 @@ rowwise.SingleCellExperiment <- function(data, ...) {
 #' @importFrom dplyr left_join
 #' @importFrom dplyr count
 #' @export
-left_join.SingleCellExperiment <- function(x, y, 
-    by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) {
-
-    # Deprecation of special column names
-    .cols <- if (!is.null(by)) by else colnames(y)
-    if (is_sample_feature_deprecated_used(x, .cols)) {
-        x <- ping_old_special_column_into_metadata(x)
-    }
-    if (is(y, "DataFrame")) y <- as.data.frame(y)
-    z <- x |>
-        as_tibble() |>
-        dplyr::left_join(y, by=by, copy=copy, suffix=suffix, ...)
-
-    # If duplicated cells returns tibble
-    if (any(duplicated(z[[c_(x)$name]]))) {
-        message(duplicated_cell_names)
-        return(z)
-    }
-
-    # Otherwise return updated tidySingleCellExperiment
-    colData(x) <- z |> as_meta_data(x)
-    return(x)
-}
+left_join.SingleCellExperiment <- .join_factory(dplyr::left_join, FALSE)
 
 #' @name inner_join
 #' @rdname inner_join
@@ -388,30 +395,7 @@ left_join.SingleCellExperiment <- function(x, y,
 #' @importFrom dplyr inner_join
 #' @importFrom dplyr pull
 #' @export
-inner_join.SingleCellExperiment <- function(x, y, 
-    by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) {
-
-    # Deprecation of special column names
-    .cols <- if (!is.null(by)) by else colnames(y)
-    if (is_sample_feature_deprecated_used(x, .cols)) {
-        x <- ping_old_special_column_into_metadata(x)
-    }
-    if (is(y, "DataFrame")) y <- as.data.frame(y)
-    z <- x |>
-        as_tibble() |>
-        dplyr::inner_join(y, by=by, copy=copy, suffix=suffix, ...)
-
-    # If duplicated cells returns tibble
-    if (any(duplicated(z[[c_(x)$name]]))) {
-        message(duplicated_cell_names)
-        return(z)
-    }
-
-    # Otherwise return updated tidySingleCellExperiment
-    new_obj <- x[, pull(z, c_(x)$name)]
-    colData(new_obj) <- z |> as_meta_data(new_obj)
-    return(new_obj)
-}
+inner_join.SingleCellExperiment <- .join_factory(dplyr::inner_join, TRUE)
 
 #' @name right_join
 #' @rdname right_join
@@ -429,30 +413,7 @@ inner_join.SingleCellExperiment <- function(x, y,
 #' @importFrom dplyr right_join
 #' @importFrom dplyr pull
 #' @export
-right_join.SingleCellExperiment <- function(x, y, 
-    by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) {
-
-    # Deprecation of special column names
-    .cols <- if (!is.null(by)) by else colnames(y)
-    if (is_sample_feature_deprecated_used(x, .cols)) {
-        x <- ping_old_special_column_into_metadata(x)
-    }
-    if (is(y, "DataFrame")) y <- as.data.frame(y)
-    z <- x |>
-        as_tibble() |>
-        dplyr::right_join(y, by=by, copy=copy, suffix=suffix, ...)
-
-    # If duplicated cells returns tibble
-    if (any(duplicated(z[[c_(x)$name]]))) {
-        message(duplicated_cell_names)
-        return(z)
-    } 
-
-    # Otherwise return updated tidySingleCellExperiment
-    new_obj <- x[, pull(z, c_(x)$name)]
-    colData(new_obj) <- z |> as_meta_data(new_obj)
-    return(new_obj)
-}
+right_join.SingleCellExperiment <- .join_factory(dplyr::right_join, TRUE)
 
 #' @name full_join
 #' @rdname full_join
@@ -466,30 +427,7 @@ right_join.SingleCellExperiment <- function(x, y,
 #' @importFrom dplyr full_join
 #' @importFrom dplyr pull
 #' @export
-full_join.SingleCellExperiment <- function(x, y, 
-    by=NULL, copy=FALSE, suffix=c(".x", ".y"), ...) {
-
-    # Deprecation of special column names
-    .cols <- if (!is.null(by)) by else colnames(y)
-    if (is_sample_feature_deprecated_used(x, .cols)) {
-        x <- ping_old_special_column_into_metadata(x)
-    }
-    if (is(y, "DataFrame")) y <- as.data.frame(y)
-    z <- x |>
-        as_tibble() |>
-        dplyr::full_join(y, by=by, copy=copy, suffix=suffix, ...) 
-
-    # If duplicated cells returns tibble
-    if (any(duplicated(z[[c_(x)$name]]))) {
-        message(duplicated_cell_names)
-        return(z)
-    }
-
-    # Otherwise return updated tidySingleCellExperiment
-    new_obj <- x[, pull(z, c_(x)$name)]
-    colData(new_obj) <- z |> as_meta_data(x)
-    return(new_obj)
-}
+full_join.SingleCellExperiment <- .join_factory(dplyr::full_join, TRUE)
 
 #' @name slice
 #' @rdname slice