Coloreando atractores
Hace unas semanas, Antonio Sánchez Chinchón escribía en su muy recomendable blog sobre las gráficas que forman algunas ecuaciones imposibles de resolver, los atractores que se ven en ellas, y la belleza de las matemáticas.
Todo ello, ilustrado con imágenes tan artísticas como:
Las gráficas me gustaron tanto que quise usarlas de fondo de pantalla. Y aprovechando que Antonio dejó el código en su GitHub, pensé en darles un toque de color, sin salir de R.
En primer lugar, eliminamos el borde de la imagen, y cambiamos algunas opciones para que la imagen final no salga cuadrada, sino apaisada.
Un ejemplo “en blanco y negro” es el siguiente:
library(Rcpp)
library(tidyverse)
library(wesanderson)
library(colorspace)
opt <- theme(legend.position = "none",
panel.background = element_rect(fill = "white"),
plot.background = element_rect(fill = "white"),
axis.ticks = element_blank(),
panel.grid = element_blank(),
axis.title = element_blank(),
axis.text = element_blank())
cppFunction('DataFrame createTrajectory(int n, double x0, double y0,
double a1, double a2, double a3, double a4, double a5, double a6, double a7,
double a8, double a9, double a10, double a11, double a12, double a13, double a14) {
// create the columns
NumericVector x(n);
NumericVector y(n);
x[0] = x0;
y[0] = y0;
for(int i = 1; i < n; ++i) {
x[i] = a1 + a2 * x[i-1] + a3 * y[i-1] + a4 * pow(fabs(x[i-1]), a5) + a6 * pow(fabs(y[i-1]), a7 );
y[i] = a8 + a9 * x[i-1] + a10 * y[i-1] + a11 * pow(fabs(x[i-1]), a12) + a13 * pow(fabs(y[i-1]), a14);
}
// return a new data frame
return DataFrame::create(_["x"]= x, _["y"]= y);
}
')
a1 <- -0.8
a2 <- 0.4
a3 <- -1.1
a4 <- 0.5
a5 <- -0.6
a6 <- -0.1
a7 <- -0.5
a8 <- 0.8
a9 <- 1.0
a10 <- -0.3
a11 <- -0.6
a12 <- -0.3
a13 <- -1.2
a14 <- -0.3
df <- createTrajectory(10000000, 1, 1, a1, a2, a3, a4, a5, a6,
a7, a8, a9, a10, a11, a12, a13, a14)
mx <- quantile(df$x, probs = 0.01)
Mx <- quantile(df$x, probs = 0.99)
my <- quantile(df$y, probs = 0.05)
My <- quantile(df$y, probs = 0.95)
df %>% filter(x > mx, x < Mx, y > my, y < My) -> df
# GRAFICO ORIGINAL
plot <- ggplot(df) +
geom_point(aes(x, y), shape = 46, alpha = 0.01, size = 0, color = "black") +
scale_x_continuous(expand = c(0,0))+
scale_y_continuous(expand = c(0,0))+
coord_fixed() +
opt
# Al pintar 10.000.000 de puntos, puede tardar un par de minutos.
ggsave("original.png", plot, height = 4, width = 8, units = 'in', dpi = 1200)
Procedemos ahora a colorear el mismo ejemplo, usando la famosa paleta de colores rainbow, y coloreando de forma circular, añadiendo algo de ruido para quitar uniformidad.
df$s <- (df$x - mean(df$x))^2 + (df$y-mean(df$y))^2 + 4*rnorm(nrow(df))
df <- df[order(df$s), ]
plot <- ggplot(df) +
geom_point(aes(x, y), shape = 46, alpha = 0.01, size = 0, color = rainbow(nrow(df))) +
scale_x_continuous(expand = c(0,0))+
scale_y_continuous(expand = c(0,0))+
coord_fixed() +
opt
ggsave("rainbow.png", plot, height = 4, width = 8, units = 'in', dpi = 1200)
También podemos usar el paquete wesanderson, que
genera paletas de color basándose en las películas de Wes Anderson. La usada en este ejemplo está basada en “El Gran Hotel Budapest”, y la imagen se colorea desde arriba hacia abajo, añadiendo también ruido. He cambiado los parámetros de la función para que la gráfica sea diferente.
a1 <- -1.0
a2 <- 0.4
a3 <- -1.1
a4 <- 0.5
a5 <- -0.6
a6 <- -0.1
a7 <- -0.5
a8 <- 0.8
a9 <- 1.0
a10 <- -0.3
a11 <- -0.6
a12 <- -0.3
a13 <- -1.2
a14 <- -0.3
df <- createTrajectory(10000000, 1, 1, a1, a2, a3, a4, a5, a6,
a7, a8, a9, a10, a11, a12, a13, a14)
mx <- quantile(df$x, probs = 0.01)
Mx <- quantile(df$x, probs = 0.99)
my <- quantile(df$y, probs = 0.05)
My <- quantile(df$y, probs = 0.95)
df %>% filter(x > mx, x < Mx, y > my, y < My) -> df
df$s <- df$y + rnorm(nrow(df))/5
df <- df[order(df$s), ]
pal <- wes_palette(nrow(df), name = "GrandBudapest1", type = "continuous")
plot <- ggplot(df) +
geom_point(aes(x, y), shape = 46, alpha = 0.01, size = 0, color = pal) +
scale_x_continuous(expand = c(0,0))+
scale_y_continuous(expand = c(0,0))+
coord_fixed() +
opt
ggsave("wes.png", plot, height = 4, width = 8, units = 'in', dpi = 1200)
Y para acabar, podemos usar también las paletas del paquete colorspace. Cambiamos los parámetros del dibujo, y la imagen se colorea en diagonal.
a1 <- -0.8
a2 <- 0.5
a3 <- -0.9
a4 <- 0.4
a5 <- -0.6
a6 <- -0.5
a7 <- -0.2
a8 <- 0.8
a9 <- 1.0
a10 <- -0.3
a11 <- -0.4
a12 <- -0.2
a13 <- -1.2
a14 <- -0.3
df <- createTrajectory(10000000, 1, 1, a1, a2, a3, a4, a5, a6,
a7, a8, a9, a10, a11, a12, a13, a14)
mx <- quantile(df$x, probs = 0.01)
Mx <- quantile(df$x, probs = 0.99)
my <- quantile(df$y, probs = 0.05)
My <- quantile(df$y, probs = 0.95)
df %>% filter(x > mx, x < Mx, y > my, y < My) -> df
df$s <- df$x + df$y + 4 * rnorm(nrow(df))
df <- df[order(df$s), ]
pal <- sequential_hcl(nrow(df), "Red-Blue")
plot <- ggplot(df) +
geom_point(aes(x, y), shape = 46, alpha = 0.01, size = 0, color = pal) +
scale_x_continuous(expand = c(0,0))+
scale_y_continuous(expand = c(0,0))+
coord_fixed() +
opt
ggsave("hcl.png", plot, height = 4, width = 8, units = 'in', dpi = 1200)
Como suele tardar un poco en guardar el gráfico, he encontrado muy útil esta línea de código, que añadida después del ggsave te avisa con un mensaje de voz cuando ha terminado el proceso. Eso sí, sólo para Mac, ya que usa su terminal.
system("say -v Jorge Hola, soy R, y he acabado el gráfico.")