Happy Vietnam Women’s Day

library(pryr)
library(tidyverse)

heart <- quote((x^2 + y^2 - 1)^3 - x^2 * y^3)

heart_at_x <- function(x) {
  function(y) eval(substitute_q(heart, list(x = x)), list(y = y))
}

heart_x <- seq(-1.136, 1.136, 0.001)
heart_y_lower <- sapply(heart_x, function(x) uniroot(heart_at_x(x), c(-2, 0.6))$root)
heart_y_upper <- sapply(heart_x, function(x) uniroot(heart_at_x(x), c(0.6, 2))$root)

heart_df <- data.frame(x = rep(heart_x, 2), 
                       y = c(heart_y_lower, heart_y_upper))

heart_df_minmax <- data.frame(x = heart_x,  
                              y_min = heart_y_lower, 
                              y_max = heart_y_upper)

set.seed(17091995)
heart_full <- apply(heart_df_minmax, 1, 
                    function(w) {
                      x <- w["x"]
                      y_min = w["y_min"]
                      y_max = w["y_max"]
                      y <- rnorm(2, mean = 0.33)
                      y <- y[between(y, y_min, y_max)]
                      x <- x[any(is.finite(y))]
                      data.frame(x, y, row.names = NULL)
                    })


heart_full <- bind_rows(heart_full)

heart_full <- heart_full %>% 
  mutate(z1 = runif(n()), 
         z2 = pmin(abs(rnorm(n())), 3), 
         order = runif(n())) %>%
  arrange(order)


library(hrbrthemes)

ggplot(heart_full, aes(x = x, y = y, color = z1, size = z2)) + 
  geom_point(pch = -1*as.hexmode(9829)) + 
  scale_color_gradient(limits = c(0, 1), low = "red3", high = "pink") + 
  scale_size(limits = c(0, 3), range = c(0.1, 20)) + 
  labs(title = "Happy Vietnam Women's Day", x = NULL, y = NULL, 
       subtitle =  "From D with Love") +  
  theme_ipsum(grid = "") + 
  theme(legend.position = "none", 
        axis.text.x = element_blank(),
        axis.text.y = element_blank(),
        axis.ticks = element_blank())

LS0tDQp0aXRsZTogIkhhcHB5IFZpZXRuYW0gV29tZW7igJlzIERheSIgDQpzdWJ0aXRsZTogIlIgZm9yIEZ1biINCmF1dGhvcjogIk5ndXllbiBDaGkgRHVuZyINCm91dHB1dDoNCiAgaHRtbF9kb2N1bWVudDogDQogICAgY29kZV9kb3dubG9hZDogdHJ1ZQ0KICAgIGNvZGVfZm9sZGluZzogaGlkZQ0KICAgIGhpZ2hsaWdodDogcHlnbWVudHMNCiAgICAjIG51bWJlcl9zZWN0aW9uczogeWVzDQogICAgdGhlbWU6ICJmbGF0bHkiDQogICAgdG9jOiBUUlVFDQogICAgdG9jX2Zsb2F0OiBUUlVFDQotLS0NCg0KYGBge3Igc2V0dXAsaW5jbHVkZT1GQUxTRX0NCmtuaXRyOjpvcHRzX2NodW5rJHNldChlY2hvID0gVFJVRSwgd2FybmluZyA9IEZBTFNFLCBtZXNzYWdlID0gRkFMU0UpDQpgYGANCg0KYGBge3J9DQpsaWJyYXJ5KHByeXIpDQpsaWJyYXJ5KHRpZHl2ZXJzZSkNCg0KaGVhcnQgPC0gcXVvdGUoKHheMiArIHleMiAtIDEpXjMgLSB4XjIgKiB5XjMpDQoNCmhlYXJ0X2F0X3ggPC0gZnVuY3Rpb24oeCkgew0KICBmdW5jdGlvbih5KSBldmFsKHN1YnN0aXR1dGVfcShoZWFydCwgbGlzdCh4ID0geCkpLCBsaXN0KHkgPSB5KSkNCn0NCg0KaGVhcnRfeCA8LSBzZXEoLTEuMTM2LCAxLjEzNiwgMC4wMDEpDQpoZWFydF95X2xvd2VyIDwtIHNhcHBseShoZWFydF94LCBmdW5jdGlvbih4KSB1bmlyb290KGhlYXJ0X2F0X3goeCksIGMoLTIsIDAuNikpJHJvb3QpDQpoZWFydF95X3VwcGVyIDwtIHNhcHBseShoZWFydF94LCBmdW5jdGlvbih4KSB1bmlyb290KGhlYXJ0X2F0X3goeCksIGMoMC42LCAyKSkkcm9vdCkNCg0KaGVhcnRfZGYgPC0gZGF0YS5mcmFtZSh4ID0gcmVwKGhlYXJ0X3gsIDIpLCANCiAgICAgICAgICAgICAgICAgICAgICAgeSA9IGMoaGVhcnRfeV9sb3dlciwgaGVhcnRfeV91cHBlcikpDQoNCmhlYXJ0X2RmX21pbm1heCA8LSBkYXRhLmZyYW1lKHggPSBoZWFydF94LCAgDQogICAgICAgICAgICAgICAgICAgICAgICAgICAgICB5X21pbiA9IGhlYXJ0X3lfbG93ZXIsIA0KICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgeV9tYXggPSBoZWFydF95X3VwcGVyKQ0KDQpzZXQuc2VlZCgxNzA5MTk5NSkNCmhlYXJ0X2Z1bGwgPC0gYXBwbHkoaGVhcnRfZGZfbWlubWF4LCAxLCANCiAgICAgICAgICAgICAgICAgICAgZnVuY3Rpb24odykgew0KICAgICAgICAgICAgICAgICAgICAgIHggPC0gd1sieCJdDQogICAgICAgICAgICAgICAgICAgICAgeV9taW4gPSB3WyJ5X21pbiJdDQogICAgICAgICAgICAgICAgICAgICAgeV9tYXggPSB3WyJ5X21heCJdDQogICAgICAgICAgICAgICAgICAgICAgeSA8LSBybm9ybSgyLCBtZWFuID0gMC4zMykNCiAgICAgICAgICAgICAgICAgICAgICB5IDwtIHlbYmV0d2Vlbih5LCB5X21pbiwgeV9tYXgpXQ0KICAgICAgICAgICAgICAgICAgICAgIHggPC0geFthbnkoaXMuZmluaXRlKHkpKV0NCiAgICAgICAgICAgICAgICAgICAgICBkYXRhLmZyYW1lKHgsIHksIHJvdy5uYW1lcyA9IE5VTEwpDQogICAgICAgICAgICAgICAgICAgIH0pDQoNCg0KaGVhcnRfZnVsbCA8LSBiaW5kX3Jvd3MoaGVhcnRfZnVsbCkNCg0KaGVhcnRfZnVsbCA8LSBoZWFydF9mdWxsICU+JSANCiAgbXV0YXRlKHoxID0gcnVuaWYobigpKSwgDQogICAgICAgICB6MiA9IHBtaW4oYWJzKHJub3JtKG4oKSkpLCAzKSwgDQogICAgICAgICBvcmRlciA9IHJ1bmlmKG4oKSkpICU+JQ0KICBhcnJhbmdlKG9yZGVyKQ0KDQoNCmxpYnJhcnkoaHJicnRoZW1lcykNCg0KZ2dwbG90KGhlYXJ0X2Z1bGwsIGFlcyh4ID0geCwgeSA9IHksIGNvbG9yID0gejEsIHNpemUgPSB6MikpICsgDQogIGdlb21fcG9pbnQocGNoID0gLTEqYXMuaGV4bW9kZSg5ODI5KSkgKyANCiAgc2NhbGVfY29sb3JfZ3JhZGllbnQobGltaXRzID0gYygwLCAxKSwgbG93ID0gInJlZDMiLCBoaWdoID0gInBpbmsiKSArIA0KICBzY2FsZV9zaXplKGxpbWl0cyA9IGMoMCwgMyksIHJhbmdlID0gYygwLjEsIDIwKSkgKyANCiAgbGFicyh0aXRsZSA9ICJIYXBweSBWaWV0bmFtIFdvbWVuJ3MgRGF5IiwgeCA9IE5VTEwsIHkgPSBOVUxMLCANCiAgICAgICBzdWJ0aXRsZSA9ICAiRnJvbSBEIHdpdGggTG92ZSIpICsgIA0KICB0aGVtZV9pcHN1bShncmlkID0gIiIpICsgDQogIHRoZW1lKGxlZ2VuZC5wb3NpdGlvbiA9ICJub25lIiwgDQogICAgICAgIGF4aXMudGV4dC54ID0gZWxlbWVudF9ibGFuaygpLA0KICAgICAgICBheGlzLnRleHQueSA9IGVsZW1lbnRfYmxhbmsoKSwNCiAgICAgICAgYXhpcy50aWNrcyA9IGVsZW1lbnRfYmxhbmsoKSkNCmBgYA0KDQo=