feat(ggpairs): Add pipe interface

[schloerke]

From an anonymous email thread

---

I'm addicted to piping

library(tidyverse)
## Warning: package 'ggplot2' was built under R version 4.4.1
library(GGally)
## Warning: package 'GGally' was built under R version 4.4.1
pm <- ggpairs(tips, mapping = aes(color = sex), columns = c("total_bill", "time", "tip"))
pm
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.

ggpairs |> formals() |> names()
##  [1] "data"                  "mapping"               "columns"              
##  [4] "title"                 "upper"                 "lower"                
##  [7] "diag"                  "params"                "..."                  
## [10] "xlab"                  "ylab"                  "axisLabels"           
## [13] "columnLabels"          "labeller"              "switch"               
## [16] "showStrips"            "legend"                "cardinality_threshold"
## [19] "progress"              "proportions"           "legends"

formals(ggpairs)
## $data
## 
## 
## $mapping
## NULL
## 
## $columns
## 1:ncol(data)
## 
## $title
## NULL
## 
## $upper
## list(continuous = "cor", combo = "box_no_facet", discrete = "count", 
##     na = "na")
## 
## $lower
## list(continuous = "points", combo = "facethist", discrete = "facetbar", 
##     na = "na")
## 
## $diag
## list(continuous = "densityDiag", discrete = "barDiag", na = "naDiag")
## 
## $params
## deprecated()
## 
## $...
## 
## 
## $xlab
## NULL
## 
## $ylab
## NULL
## 
## $axisLabels
## c("show", "internal", "none")
## 
## $columnLabels
## colnames(data[columns])
## 
## $labeller
## [1] "label_value"
## 
## $switch
## NULL
## 
## $showStrips
## NULL
## 
## $legend
## NULL
## 
## $cardinality_threshold
## [1] 15
## 
## $progress
## NULL
## 
## $proportions
## NULL
## 
## $legends
## deprecated()

new_tidypivot <- function(){}
formals(new_tidypivot) <- formals(ggpairs)
formals(new_tidypivot)$upper <- "blank" #
formals(new_tidypivot)$lower <- "blank" #

body(new_tidypivot) <- quote({
  
  pairs_obj <- list(
    # data = data,
    # mapping = mapping,
    # columns = columns,
    # title = title,
    upper = upper,
    lower = lower
  )

  # declare class 'tidypivot'
  class(pairs_obj) <- "tidypivot"

  # Return the created object
  invisible(pairs_obj)
  
})


#' @export
print.tidypivot <- function(pairs_obj){
  
  print(do.call(ggpairs, pairs_obj))
  
  invisible(pairs_obj)
  
}

#' @export
ggpairs_piped <- function(data = NULL){
  
  data <- data %||% data.frame()
  
  pairs_obj <- new_tidypivot()
  
  pairs_obj$data <- data
  
  last_pairs_obj <<- pairs_obj
  
  pairs_obj

}


#' @export
last_ggpairs <- function(){
  
  last_pairs_obj
  
}


set_columns <- function(pairs_obj, columns = NULL){
  pairs_obj$columns <- columns
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_mapping <- function(pairs_obj, mapping = NULL){
  pairs_obj$mapping <- mapping
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_upper <- function(pairs_obj, upper = formals(ggpairs)$upper){
  pairs_obj$upper <- upper
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_lower <- function(pairs_obj, lower = formals(ggpairs)$lower){
  pairs_obj$lower <- lower
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_diag <- function(pairs_obj, diag = NULL){
  pairs_obj$diag <- diag
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_xlab <- function(pairs_obj, xlab = NULL){
  pairs_obj$xlab <- xlab
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_ylab <- function(pairs_obj, ylab = NULL){
  pairs_obj$ylab <- ylab
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_columnLabels <- function(pairs_obj, columnLabels = NULL){
  pairs_obj$columnLabels <- columnLabels
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_labeller <- function(pairs_obj, labeller = NULL){
  pairs_obj$labeller <- labeller
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_switch <- function(pairs_obj, switch = NULL){
  pairs_obj$switch <- switch
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_showStrips <- function(pairs_obj, showStrips = NULL){
  pairs_obj$showStrips <- showStrips
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_legend <- function(pairs_obj, legend = NULL){
  pairs_obj$legend <- legend
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_cardinality_threshold <- function(pairs_obj, cardinality_threshold = NULL){
  pairs_obj$cardinality_threshold <- cardinality_threshold
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_progress <- function(pairs_obj, progress = NULL){
  pairs_obj$progress <- progress
  last_pairs_obj <<- pairs_obj
  pairs_obj
}

set_proportions <- function(pairs_obj, proportions = NULL){
  pairs_obj$proportions <- proportions
  last_pairs_obj <<- pairs_obj
  pairs_obj
}



set_title <- function(pairs_obj, title = NULL){

  pairs_obj$title <- title

  last_pairs_obj <<- pairs_obj

  pairs_obj
  
}


collect <- function(pairs_obj){
  
  do.call(ggpairs, pairs_obj)
  
}

ggpairs_piped(tips) 

last_ggpairs() |>
  set_columns(c("total_bill", "time", "tip")) 

last_ggpairs() |>
  set_columnLabels(c("Total Bill", "Lunch or Dinner", "Tip"))

last_ggpairs() |> 
  set_lower()  # brings in ggpairs defaults
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.

last_ggpairs() |> 
  set_mapping(aes(color = time, alpha = I(.7)))
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.

last_ggpairs() |> 
  set_upper()
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.

last_ggpairs() |>
  set_title("A ggpairs plot!")
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.
## `stat_bin()` using `bins = 30`. Pick better value `binwidth`.

ggpairs_piped(tips) |> # simple start univariate plots 
  # to ggpairs - pairwise plots
  set_lower() |> 
  set_upper() |>
  # Columns and Mapping
  set_columns(c("tip", "total_bill", 
                "time", "smoker")) |> 
  set_columns(c( 2, 1, 6, 4)) |>
  set_columnLabels( c("Tip", "Total Bill", 
                      "Time of Day", "Smoker")) |>
  set_mapping(aes(color = time)) |> 
  set_mapping(aes(color = time, alpha = I(.7))) |> 
  # Matrix Sections
  set_lower(list(continuous = "smooth", 
                 combo = "facetdensity",
                 discrete = "crosstable", 
                 mapping = aes(color = NULL))) |>
  set_upper("blank") |>
  set_diag("blank") |>
  collect() ->
pairs


pairs[2, 1] +
  theme_dark() ->
pairs[2, 1]
  
pairs

[EvaMaeRey]

Thank you for going through the code the other day! I added this type of function for changing different combos in an isolated way and it does feel a lot nicer! e.g.:

pairs_lower_continuous <- function(pairs_obj, lower_continuous = NULL){

  if(pairs_obj$lower == "blank"){pairs_obj$lower <- formals(ggpairs)$lower}
  pairs_obj$lower$continuous <- lower_continuous
  pairs_obj

}

pairs_lower_combo <- function(pairs_obj, lower_combo = NULL){

  if(pairs_obj$lower == "blank"){pairs_obj$lower <- formals(ggpairs)$lower}
  pairs_obj$lower$combo <- lower_combo
  pairs_obj

  }

This let's you do:

ggpairs2(tips) |>  # simple start univariate plots
# to ggpairs - pairwise plots
  pairs_lower() |>
  pairs_upper() |>
# Columns and Mapping
  pairs_columns(c("tip", "total_bill",
                "time", "smoker")) |>
  pairs_columns(c( 2, 1, 6, 4)) |>
  pairs_columnLabels( c("Tip", "Total Bill",
                      "Time of Day", "Smoker")) |>
  pairs_mapping(aes(color = time)) |>
# Matrix Sections
  pairs_lower_continuous("smooth") |>                          # less awkward!
  pairs_lower_combo("facetdensity") |>                       
  pairs_lower_discrete("crosstable") |>
  pairs_lower_mapping(aes(color = NULL)) |>
  pairs_upper("blank") |>
  pairs_upper_discrete("crosstable") |>
  pairs_diag("blank") |>
  pairs_mapping(aes(color = time, alpha = I(.7))) |>     # might still be nice to append mapping
  as_plot() ->

[smouksassi]

this is pure magic @schloerke Thank you ! sorry I missed your presentation the other day is there a recording?