0.9.7 a new fct identical_cols

Author: abusjahn

CRAN-SUBMISSION

@@ -1,3 +1,3 @@
 Version: 0.9.6
-Date: 2024-10-10 09:11:05 UTC
-SHA: 36d1276af66be31fa3c87d390016725f810962b8
+Date: 2024-10-10 11:37:51 UTC
+SHA: c0238c1521c02218a6308200db1b5091b27e13ce

DESCRIPTION

@@ -10,8 +10,8 @@ Description: The main functionalities of 'wrappedtools' are:
     descriptive statistics and p-values; creating specialized plots for 
     correlation matrices. Functions were mainly written for my own daily work or 
     teaching, but may be of use to others as well.
-Version: 0.9.6
-Date: 2024-10-10
+Version: 0.9.7
+Date: 2025-03-25
 Authors@R: c(
     person(given = "Andreas",
            family = "Busjahn",

NAMESPACE

@@ -19,6 +19,7 @@ export(flex2rmd)
 export(formatP)
 export(ggcormat)
 export(glmCI)
+export(identical_cols)
 export(ksnormal)
 export(label_outliers)
 export(logrange_1)

NEWS.md

@@ -1,3 +1,6 @@
+#wrappedtools 0.9.7
+- function identical_cols to find and remove duplicated columns
+
 #wrappedtools 0.9.6
 - function ksnormal now uses Lilliefors test by default
 - example for compare_n_numvars was corrected

R/basefunctions.R

@@ -399,7 +399,7 @@ ColSeeker <- function(data=rawdata,
 #' @param nrows number of rows (30) before splitting.
 #' @param ncols number of columns (100) before splitting.
 #' @param caption header.
-#' @param ... Further arguments passed to [kable].
+#' @param ... Further arguments passed to [knitr::kable].
 #' @return No return value, called for side effects.
 #' 
 #' @examples 
@@ -448,7 +448,7 @@ print_kable <- function(t, nrows = 30, caption = "",
 #' @param innercaption subheader
 #' @param caption header
 #' @param foot footnote
-#' @param escape see kable
+#' @param escape see [knitr::kable]
 #'
 #'@return A character vector of the table source code. 
 #' @export
@@ -590,3 +590,112 @@ flex2rmd <- function(ft){
     return(flextable_to_rmd(ft))
   }
 }
+
+
+#' Find and optionally remove identical columns in a data frame.
+#'
+#' This function identifies columns with identical values in a data frame and
+#' provides options to remove them, clean column names, and print the duplicated groups.
+#' It also includes an interactive mode where the user can choose to remove all,
+#' some, or none of the duplicated columns.
+#'
+#' @param df A data frame or tibble.
+#' @param interactive Logical. If TRUE, the function prompts the user to choose how
+#'   to handle duplicated columns. Defaults to TRUE.
+#' @param remove_duplicates Logical. If TRUE, removes duplicated columns. Defaults to TRUE.
+#' @param clean_names Logical. If TRUE, cleans column names by removing trailing
+#'   "..." followed by digits. Defaults to TRUE.
+#' @param print_duplicates Logical. If TRUE, prints the groups of duplicated columns.
+#'   Defaults to TRUE.
+#'
+#' @return A data frame with optionally removed and renamed columns.
+#'
+#' @examples
+#' library(tibble)
+#'
+#' dummy <- tibble(
+#'   A...1 = rnorm(10),
+#'   A...2 = A...1,
+#'   C = sample(letters, 10),
+#'   A...4 = A...1,
+#'   E = sample(1:10, 10),
+#'   `F` = C
+#' )
+#'
+#' # Example usage:
+#' identical_cols(dummy) # Interactive removal
+#' identical_cols(dummy, remove_duplicates = FALSE) # Find identical columns only
+#' identical_cols(dummy, print_duplicates = FALSE) # Interactive removal, no print
+#' identical_cols(dummy, clean_names = FALSE) # Interactive removal, no clean names
+#' identical_cols(dummy, interactive = FALSE) #Non interactive removal of all duplicates.
+#'
+#' @export
+identical_cols <- function(df,
+                           interactive = TRUE,
+                           remove_duplicates = TRUE,
+                           clean_names = TRUE,
+                           print_duplicates = TRUE) {
+  col_names <- names(df)
+  identical.cols <-
+    purrr::map(col_names, function(current_col) {
+      col_names[purrr::map_lgl(df, ~ identical(.x, df[[current_col]]))]
+    })
+  names(identical.cols) <- col_names
+  duplicated_groups <- unique(identical.cols[purrr::map_lgl(identical.cols, ~ length(.x) > 1)])
+  
+  if (print_duplicates) {
+    print(duplicated_groups)
+  }
+  
+  if (remove_duplicates) {
+    if(interactive &
+       length(duplicated_groups) > 0) {
+      user_choice <- readline("Remove (a)ll, (s)ome, or (n)one of the duplicates? (a/s/n): ")
+    } else{
+      user_choice = "a"
+    }
+    if (user_choice == "a") {
+      cols_to_remove <- col_names[col_names %in% unlist(
+        purrr::map(duplicated_groups, ~ .x[-1])
+      )]
+      cols_to_keep <-
+        col_names[!col_names %in% unlist(
+          purrr::map(duplicated_groups, ~ .x[-1])
+        )]
+      df <- df[, cols_to_keep, drop = FALSE]
+      if (clean_names) {
+        df <- rename_with(
+          df,
+          .cols = all_of(cols_to_keep),
+          .fn = ~ str_remove(.x, "\\.{3}\\d+$")
+        )
+      }
+    } else if (user_choice == "s") {
+      cn2rename <- ""
+      cols_to_remove <- character(0)
+      for (group in duplicated_groups) {
+        cat(paste0("Duplicate group:\n", paste0("- ",
+                                                group,
+                                                collapse = "\n")))
+        remove_group <- readline("Remove this duplication? (y/n): ")
+        
+        if (remove_group == "y") {
+          cols_to_remove <- c(cols_to_remove, group[-1])
+          cn2rename <- c(cn2rename,group[1])
+        }
+      }
+      cols_to_keep <- col_names[!col_names %in% cols_to_remove]
+      df <- df[, cols_to_keep, drop = FALSE]
+      if (clean_names) {
+        df <- rename_with(
+          df,
+          .cols = any_of(cn2rename),
+          .fn = ~ str_remove(.x, "\\.{3}\\d+$")
+        )
+      }
+    } else {
+      cols_to_keep <- col_names
+    }
+    return(df)
+  }
+}

R/tests.R

@@ -870,13 +870,13 @@ compare_n_qualvars <- function(data, dep_vars, indep_var,
 #'
 #' \code{pairwise_wilcox_test} calculates pairwise comparisons on ordinal data
 #' between all group levels with corrections for multiple testing based on
-#' \link{wilcox_test} from package 'coin'.
+#' [coin::wilcox_test] from package 'coin'.
 #'
 #' @param dep_var dependent variable, containing the data.
 #' @param indep_var independent variable, should be factor.
 #' @param strat_var optional factor for stratification.
 #' @param adjmethod method for adjusting p values (see [p.adjust])
-#' @param distr Computation of p-values, see \link{wilcox_test}.
+#' @param distr Computation of p-values, see [coin::wilcox_test].
 #' @param plevel threshold for significance.
 #' @param symbols predefined as b,c, d...;  provides footnotes to mark group
 #' differences, e.g. b means different from group 2.