A slightly different approach to what’s currently in ggdims.
library(tidyverse)
dims <- function(...){}
dims_expand2 <- function(select) {
structure(
list(),
class = "dims_expand2"
)
}
#' @import ggplot2
#' @importFrom ggplot2 ggplot_add
#' @export
ggplot_add.dims_expand2 <- function(object, plot, object_name) {
# get expression inside of dims parentheses in `aes(dims = dims(var1:var10))`
# would return "var1:var10"
select_specs <- plot$mapping$dims[[2]] |>
as.character() |>
_[-1] |>
paste(collapse = ", ")
# from plot data point to the select_specs variables that are specified
# and save a data frame, in features_df
features_df <- paste0("select(plot$data,", select_specs, ")") |>
rlang::parse_expr() |>
eval()
# create a vector added to the plot data
plot$data$.dims_stasher <- vector("list", nrow(plot$data))
for (i in 1:nrow(features_df)){
# store the features data as a 1 row data frame in vector .dims_stasher...
plot$data$.dims_stasher[[i]] <- features_df[i,]
}
# overwrite dims mapping to point to new vector that contains features_df
plot$mapping <- modifyList(plot$mapping, aes(dims = .dims_stasher))
plot
}
dims <- function(){}
ggplot(mtcars) +
aes(dims = dims(mpg:drat, qsec), x = 1, y = 1) +
geom_point() +
dims_expand2()
## Warning: Subsetting quosures with `[[` is deprecated as of rlang 0.4.0
## Please use `quo_get_expr()` instead.
## This warning is displayed once every 8 hours.
p <- last_plot()
p$mapping
## Aesthetic mapping:
## * `x` -> 1
## * `y` -> 1
## * `dims` -> `.dims_stasher`
p$data$.dims_stasher[[1]]
## mpg cyl disp hp drat qsec
## Mazda RX4 21 6 160 110 3.9 16.46
p$data$.dims_stasher |>
bind_rows() |>
ggdims:::pca_layout()
## # A tibble: 32 × 6
## PC1 PC2 PC3 PC4 PC5 PC6
## <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 -0.569 0.849 -0.365 0.381 -0.498 -0.0411
## 2 -0.661 0.622 -0.209 0.326 -0.440 -0.127
## 3 -1.84 -0.0330 0.0120 0.472 0.120 0.308
## 4 -0.204 -1.37 -0.366 -0.230 0.0616 0.116
## 5 1.64 -0.233 -0.432 -0.522 -0.202 -0.0427
## 6 -0.0359 -2.10 -0.360 0.345 0.215 0.0195
## 7 2.56 0.502 -0.0550 -0.0120 0.268 0.110
## 8 -2.13 -0.913 0.0217 0.0439 -0.0283 0.308
## 9 -2.46 -1.73 1.35 -0.137 0.468 -0.237
## 10 -0.645 0.126 0.375 0.349 -0.261 -0.281
## # ℹ 22 more rows
then a new compute…
compute_pca_rows <- function (data, scales){
data_for_reduction <- data$dims |> bind_rows()
clean_data <- remove_missing(bind_cols(data_for_reduction,
data |> select(-"dims")))
# set.seed(1345)
clean_data[names(data_for_reduction)] |>
ggdims:::pca_layout() |>
bind_cols(clean_data)
}
StatPca <- ggproto("StatPca", Stat, compute_panel = compute_pca_rows,
default_aes =
aes(x = after_stat(PC1),
y = after_stat(PC2)))
ggplot(mtcars) +
aes(dims = dims(mpg:drat, qsec)) +
dims_expand2() +
geom_point(stat = StatPca)
layer_data()
## PC1 PC2 PC3 PC4 PC5 PC6 mpg
## 1 -0.5685952 0.84898005 -0.36520768 0.38076082 -0.49765844 -0.04111557 21.0
## 2 -0.6609821 0.62175339 -0.20930295 0.32573003 -0.43977398 -0.12688943 21.0
## 3 -1.8354366 -0.03297278 0.01197355 0.47189407 0.12036726 0.30806796 22.8
## 4 -0.2035116 -1.36882397 -0.36607373 -0.23024290 0.06164315 0.11584403 21.4
## 5 1.6428524 -0.23338608 -0.43159980 -0.52167827 -0.20180499 -0.04274421 18.7
## 6 -0.0359078 -2.09857825 -0.35994069 0.34519767 0.21541539 0.01946672 18.1
## 7 2.5582649 0.50191877 -0.05500559 -0.01197871 0.26757152 0.11024182 14.3
## 8 -2.1321425 -0.91254205 0.02171106 0.04392743 -0.02829995 0.30767949 24.4
## 9 -2.4572800 -1.72827882 1.35447822 -0.13663282 0.46765613 -0.23749019 22.8
## 10 -0.6451107 0.12632603 0.37494912 0.34915166 -0.26051488 -0.28073968 19.2
## 11 -0.6423543 -0.15154325 0.64647312 0.45637183 -0.25476871 -0.34574763 17.8
## 12 1.5258791 -0.40808734 -0.37231966 0.15069047 0.05079713 -0.38405946 16.4
## 13 1.4274780 -0.46711763 -0.38380717 0.02420551 0.10764558 -0.43198108 17.3
## 14 1.5141009 -0.68104060 -0.11572183 0.23417039 0.06458228 -0.45290921 15.2
## 15 2.8239402 -1.07633988 0.51932185 -0.18221547 -0.23521811 0.44345481 10.4
## 16 2.8244060 -0.87736173 0.58053185 -0.14117012 -0.14842847 0.38646415 10.4
## 17 2.4507973 -0.26876153 0.45128124 -0.59804782 0.07108473 0.20079134 14.7
## 18 -3.0996416 0.02663848 -0.36155268 -0.62379805 0.22392396 -0.15261733 32.4
## 19 -3.4470042 1.23900134 0.46223782 -0.48536272 -0.59609053 -0.19266536 30.4
## 20 -3.4040638 0.04753944 -0.20569103 -0.84217220 0.25507989 -0.31485052 33.9
## 21 -1.8058452 -0.79513370 0.35970674 0.46197432 0.31572826 0.20305449 21.5
## 22 1.8437259 -0.73453250 -0.87753770 0.22952627 -0.30763207 0.01126956 15.5
## 23 1.4912963 -0.47165399 -0.29833372 0.18776227 -0.46553057 -0.21170149 15.2
## 24 2.3288487 1.23424887 0.49767981 0.05860537 -0.09162956 0.01337071 13.3
## 25 1.7916475 -0.35868651 -0.47429048 -0.76603868 -0.23460828 0.12463206 19.2
## 26 -2.6338865 0.13219938 -0.13910604 0.03608427 -0.04070977 0.03387327 27.3
## 27 -2.0966577 1.43326026 -0.06009128 0.06430236 -0.33401447 0.43426868 26.0
## 28 -1.9748274 0.86103273 -1.06081960 -0.20783205 0.55538981 0.36589228 30.4
## 29 2.1028878 2.28221451 0.72202870 -0.31674187 -0.15112612 -0.05040515 15.8
## 30 0.2197871 1.19524373 -0.60859826 0.67620620 0.29304877 0.05691350 19.7
## 31 2.8502266 1.84017703 0.22910147 0.08959756 1.15191833 -0.16610375 15.0
## 32 -1.7528917 0.27430663 0.51352535 0.47775317 0.06595668 0.29673519 21.4
## cyl disp hp drat qsec PANEL group x y shape colour
## 1 6 160.0 110 3.90 16.46 1 -1 -0.5685952 0.84898005 19 black
## 2 6 160.0 110 3.90 17.02 1 -1 -0.6609821 0.62175339 19 black
## 3 4 108.0 93 3.85 18.61 1 -1 -1.8354366 -0.03297278 19 black
## 4 6 258.0 110 3.08 19.44 1 -1 -0.2035116 -1.36882397 19 black
## 5 8 360.0 175 3.15 17.02 1 -1 1.6428524 -0.23338608 19 black
## 6 6 225.0 105 2.76 20.22 1 -1 -0.0359078 -2.09857825 19 black
## 7 8 360.0 245 3.21 15.84 1 -1 2.5582649 0.50191877 19 black
## 8 4 146.7 62 3.69 20.00 1 -1 -2.1321425 -0.91254205 19 black
## 9 4 140.8 95 3.92 22.90 1 -1 -2.4572800 -1.72827882 19 black
## 10 6 167.6 123 3.92 18.30 1 -1 -0.6451107 0.12632603 19 black
## 11 6 167.6 123 3.92 18.90 1 -1 -0.6423543 -0.15154325 19 black
## 12 8 275.8 180 3.07 17.40 1 -1 1.5258791 -0.40808734 19 black
## 13 8 275.8 180 3.07 17.60 1 -1 1.4274780 -0.46711763 19 black
## 14 8 275.8 180 3.07 18.00 1 -1 1.5141009 -0.68104060 19 black
## 15 8 472.0 205 2.93 17.98 1 -1 2.8239402 -1.07633988 19 black
## 16 8 460.0 215 3.00 17.82 1 -1 2.8244060 -0.87736173 19 black
## 17 8 440.0 230 3.23 17.42 1 -1 2.4507973 -0.26876153 19 black
## 18 4 78.7 66 4.08 19.47 1 -1 -3.0996416 0.02663848 19 black
## 19 4 75.7 52 4.93 18.52 1 -1 -3.4470042 1.23900134 19 black
## 20 4 71.1 65 4.22 19.90 1 -1 -3.4040638 0.04753944 19 black
## 21 4 120.1 97 3.70 20.01 1 -1 -1.8058452 -0.79513370 19 black
## 22 8 318.0 150 2.76 16.87 1 -1 1.8437259 -0.73453250 19 black
## 23 8 304.0 150 3.15 17.30 1 -1 1.4912963 -0.47165399 19 black
## 24 8 350.0 245 3.73 15.41 1 -1 2.3288487 1.23424887 19 black
## 25 8 400.0 175 3.08 17.05 1 -1 1.7916475 -0.35868651 19 black
## 26 4 79.0 66 4.08 18.90 1 -1 -2.6338865 0.13219938 19 black
## 27 4 120.3 91 4.43 16.70 1 -1 -2.0966577 1.43326026 19 black
## 28 4 95.1 113 3.77 16.90 1 -1 -1.9748274 0.86103273 19 black
## 29 8 351.0 264 4.22 14.50 1 -1 2.1028878 2.28221451 19 black
## 30 6 145.0 175 3.62 15.50 1 -1 0.2197871 1.19524373 19 black
## 31 8 301.0 335 3.54 14.60 1 -1 2.8502266 1.84017703 19 black
## 32 4 121.0 109 4.11 18.60 1 -1 -1.7528917 0.27430663 19 black
## fill size alpha stroke
## 1 NA 1.5 NA 0.5
## 2 NA 1.5 NA 0.5
## 3 NA 1.5 NA 0.5
## 4 NA 1.5 NA 0.5
## 5 NA 1.5 NA 0.5
## 6 NA 1.5 NA 0.5
## 7 NA 1.5 NA 0.5
## 8 NA 1.5 NA 0.5
## 9 NA 1.5 NA 0.5
## 10 NA 1.5 NA 0.5
## 11 NA 1.5 NA 0.5
## 12 NA 1.5 NA 0.5
## 13 NA 1.5 NA 0.5
## 14 NA 1.5 NA 0.5
## 15 NA 1.5 NA 0.5
## 16 NA 1.5 NA 0.5
## 17 NA 1.5 NA 0.5
## 18 NA 1.5 NA 0.5
## 19 NA 1.5 NA 0.5
## 20 NA 1.5 NA 0.5
## 21 NA 1.5 NA 0.5
## 22 NA 1.5 NA 0.5
## 23 NA 1.5 NA 0.5
## 24 NA 1.5 NA 0.5
## 25 NA 1.5 NA 0.5
## 26 NA 1.5 NA 0.5
## 27 NA 1.5 NA 0.5
## 28 NA 1.5 NA 0.5
## 29 NA 1.5 NA 0.5
## 30 NA 1.5 NA 0.5
## 31 NA 1.5 NA 0.5
## 32 NA 1.5 NA 0.5
ggplot(iris) +
aes(dims = dims(Sepal.Length:Petal.Width),
color = Species) +
# --------- the following gets wrapped up to geom_pca ------------
dims_expand2() +
geom_point(stat = StatPca)
knitr::knit_exit()