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 (quizá escriba pronto un post con otras opciones para Windows, o multiplataforma).

system("say -v Jorge Hola, soy R, y he acabado el gráfico.")