Add a custom adorn function

[larry77]

I do not know if this should be a pull request, but I would like to have an adorn_function where I can specify any function I want to add an extra row with some stats.
Something along the line of the function below (not tested under all possible circumstances).
Thanks!

library(dplyr)
#> 
#> Attaching package: 'dplyr'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, lag
#> The following objects are masked from 'package:base':
#> 
#>     intersect, setdiff, setequal, union
library(janitor)
#> 
#> Attaching package: 'janitor'
#> The following objects are masked from 'package:stats':
#> 
#>     chisq.test, fisher.test



# Define the custom function to add a row with an arbitrary function and custom value for non-numeric columns
adorn_custom <- function(df, fun, exclude = NULL, na.rm = TRUE, position = "bottom", custom_values = list()) {
  
  # Identify numeric columns where the function should be applied, excluding specified columns
  cols_to_apply <- df |>
    select(where(is.numeric)) |>
    select(-all_of(exclude)) |>
    colnames()
  
  # Apply the function to the selected numeric columns
  custom_row <- df |>
    summarise(across(all_of(cols_to_apply), ~ fun(., na.rm = na.rm)))
  
  # Create a new row with NA for all columns first
  custom_row_full <- df[1, ] |> 
    summarise(across(everything(), ~ NA)) |> 
    mutate(across(all_of(cols_to_apply), ~ custom_row[[cur_column()]]))
  
  # Assign custom values for non-numeric (or excluded) columns
  for (col_name in names(custom_values)) {
    if (col_name %in% colnames(df)) {
      custom_row_full[[col_name]] <- custom_values[[col_name]]
    }
  }
  
  # Add the custom row at the specified position
  if (position == "top") {
    df_with_custom <- bind_rows(custom_row_full, df)
  } else if (position == "bottom") {
    df_with_custom <- bind_rows(df, custom_row_full)
  } else {
    stop("Invalid position. Use 'top' or 'bottom'.")
  }
  
  return(df_with_custom)
}

# Example usage
# Sample dataframe with a 'Year' and 'Category' column
df <- data.frame(
  Category = c("A", "B", "C"),
  Year = c(2020, 2021, 2022),
  Value1 = c(10, 20, 30),
  Value2 = c(40, 50, 60)
)

# Add a row with the mean, exclude 'Year', and set a custom value for the 'Category' column
df_with_mean_top <- adorn_custom(
  df, 
  mean, 
  exclude = c("Year"), 
  position = "top", 
  custom_values = list(Category = "Summary")
)
print(df_with_mean_top)
#>   Category Year Value1 Value2
#> 1  Summary   NA     20     50
#> 2        A 2020     10     40
#> 3        B 2021     20     50
#> 4        C 2022     30     60

# Add a row with the mean, exclude 'Year', and set a custom value for the 'Category' column at the bottom
df_with_mean_bottom <- adorn_custom(
  df, 
  mean, 
  exclude = c("Year"), 
  position = "bottom", 
  custom_values = list(Category = "Mean Summary")
)
print(df_with_mean_bottom)
#>       Category Year Value1 Value2
#> 1            A 2020     10     40
#> 2            B 2021     20     50
#> 3            C 2022     30     60
#> 4 Mean Summary   NA     20     50


sessionInfo()
#> R version 4.4.1 (2024-06-14)
#> Platform: x86_64-pc-linux-gnu
#> Running under: Debian GNU/Linux 12 (bookworm)
#> 
#> Matrix products: default
#> BLAS:   /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.11.0 
#> LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.11.0
#> 
#> locale:
#>  [1] LC_CTYPE=en_GB.UTF-8       LC_NUMERIC=C              
#>  [3] LC_TIME=en_GB.UTF-8        LC_COLLATE=en_GB.UTF-8    
#>  [5] LC_MONETARY=en_GB.UTF-8    LC_MESSAGES=en_GB.UTF-8   
#>  [7] LC_PAPER=en_GB.UTF-8       LC_NAME=C                 
#>  [9] LC_ADDRESS=C               LC_TELEPHONE=C            
#> [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C       
#> 
#> time zone: Europe/Brussels
#> tzcode source: system (glibc)
#> 
#> attached base packages:
#> [1] stats     graphics  grDevices utils     datasets  methods   base     
#> 
#> other attached packages:
#> [1] janitor_2.2.0 dplyr_1.1.4  
#> 
#> loaded via a namespace (and not attached):
#>  [1] vctrs_0.6.5       cli_3.6.3         knitr_1.48        rlang_1.1.4      
#>  [5] xfun_0.47         stringi_1.8.4     generics_0.1.3    glue_1.7.0       
#>  [9] htmltools_0.5.8.1 fansi_1.0.6       rmarkdown_2.28    snakecase_0.11.1 
#> [13] evaluate_0.24.0   tibble_3.2.1      fastmap_1.2.0     yaml_2.3.10      
#> [17] lifecycle_1.0.4   stringr_1.5.1     compiler_4.4.1    fs_1.6.4         
#> [21] timechange_0.3.0  pkgconfig_2.0.3   digest_0.6.37     R6_2.5.1         
#> [25] reprex_2.1.1      tidyselect_1.2.1  utf8_1.2.4        pillar_1.9.0     
#> [29] magrittr_2.0.3    tools_4.4.1       withr_3.0.1       lubridate_1.9.3

^{Created on 2024-10-18 with reprex v2.1.1}