Merge pull request #65 from hrbrmstr/picto

Picto

.gitignore

@@ -5,3 +5,4 @@
 src/*.o
 src/*.so
 src/*.dll
+inst/doc

DESCRIPTION

@@ -26,10 +26,15 @@ Encoding: UTF-8
 URL: https://gitlab.com/hrbrmstr/waffle
 BugReports: https://gitlab.com/hrbrmstr/waffle/issues
 Suggests:
-    testthat
+    testthat,
+    knitr,
+    rmarkdown,
+    dplyr,
+    hrbrthemes,
+    ggthemes
 Depends:
-    R (>= 3.2.0),
-    ggplot2 (>= 2.0.0)
+    R (>= 3.5.0),
+    ggplot2 (>= 3.1.0)
 License: GPL (>= 2)
 Imports:
     RColorBrewer,
@@ -41,5 +46,8 @@ Imports:
     stringr,
     stats,
     htmlwidgets,
-    DT
+    DT,
+    rlang,
+    utils
 RoxygenNote: 6.1.1
+VignetteBuilder: knitr

NAMESPACE

@@ -1,12 +1,16 @@
 # Generated by roxygen2: do not edit by hand
 
+export(GeomPictogram)
 export(GeomWaffle)
 export(StatWaffle)
+export(draw_key_pictogram)
 export(fa_grep)
 export(fa_list)
+export(geom_pictogram)
 export(geom_waffle)
 export(install_fa_fonts)
 export(iron)
+export(scale_label_pictogram)
 export(stat_waffle)
 export(theme_enhance_waffle)
 export(waffle)
@@ -20,7 +24,9 @@ importFrom(extrafont,choose_font)
 importFrom(extrafont,font_import)
 importFrom(extrafont,ttf_import)
 importFrom(ggplot2,aes)
+importFrom(ggplot2,alpha)
 importFrom(ggplot2,coord_equal)
+importFrom(ggplot2,discrete_scale)
 importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_rect)
 importFrom(ggplot2,element_text)
@@ -40,11 +46,17 @@ importFrom(ggplot2,scale_y_continuous)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_bw)
 importFrom(grid,arrow)
+importFrom(grid,gpar)
 importFrom(grid,grid.draw)
 importFrom(grid,grid.newpage)
+importFrom(grid,grobTree)
+importFrom(grid,roundrectGrob)
+importFrom(grid,textGrob)
 importFrom(grid,unit)
 importFrom(grid,unit.c)
 importFrom(grid,unit.pmax)
 importFrom(grid,unit.pmin)
 importFrom(gtable,is.gtable)
+importFrom(rlang,is_missing)
 importFrom(stats,setNames)
+importFrom(utils,tail)

R/a-geom-rect.R

@@ -0,0 +1,66 @@
+geom_rrect <- function(mapping = NULL, data = NULL, # nocov start
+                       stat = "identity", position = "identity",
+                       radius = grid::unit(6, "pt"),
+                       ...,
+                       na.rm = FALSE,
+                       show.legend = NA,
+                       inherit.aes = TRUE) {
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomRrect,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      radius = radius,
+      na.rm = na.rm,
+      ...
+    )
+  )
+}
+
+GeomRrect <- ggplot2::ggproto(
+  "GeomRrect", ggplot2::Geom,
+
+  default_aes = ggplot2::aes(
+    fill = "grey35", size = 0.5, linetype = 1, alpha = NA#, colour = NA
+  ),
+
+  required_aes = c("xmin", "xmax", "ymin", "ymax"),
+
+  draw_panel = function(self, data, panel_params, coord,
+                        radius = grid::unit(6, "pt")) {
+
+    coords <- coord$transform(data, panel_params)
+
+    lapply(1:length(coords$xmin), function(i) {
+
+      grid::roundrectGrob(
+        coords$xmin[i], coords$ymax[i],
+        width = (coords$xmax[i] - coords$xmin[i]),
+        height = (coords$ymax[i] - coords$ymin)[i],
+        r = radius,
+        default.units = "native",
+        just = c("left", "top"),
+        gp = grid::gpar(
+          col = coords$colour[i],
+          fill = alpha(coords$fill[i], coords$alpha[i]),
+          lwd = coords$size[i] * .pt,
+          lty = coords$linetype[i],
+          lineend = "butt"
+        )
+      )
+
+    }) -> gl
+
+    grobs <- do.call(grid::gList, gl)
+
+    ggname("geom_rrect", grid::grobTree(children = grobs))
+
+  },
+
+  draw_key = ggplot2::draw_key_polygon
+
+) # nocov end

R/aaa.r

@@ -1 +1,9 @@
-utils::globalVariables(c("x", "y", "value"))
+utils::globalVariables(c("x", "y", "value"))
+
+.dbg <- TRUE
+
+msg <- function(...) {
+
+  if (.dbg) message(...)
+
+}

R/fontawesome.R

@@ -2,39 +2,8 @@
 # This variation updates it from the latests css from github
 .fa_unicode_init <- function() {
 
-  # fa_lib <- readLines(system.file("css", "fontawesome.css", package="waffle"))
-
-  # fa_json <- jsonlite::fromJSON(system.file("json", "icons.json", package="waffle"))
-  #
-  # data.frame(
-  #   name = names(fa_json),
-  #   type = vapply(fa_json, function(.x, wat) .x[[wat]][[1]],
-  #                 character(1), "free", USE.NAMES = FALSE),
-  #   unicode = vapply(fa_json, function(.x, wat) .x[[wat]][[1]],
-  #                    character(1), "unicode", USE.NAMES = FALSE),
-  #   stringsAsFactors = FALSE
-  # ) -> fa_df
-  #
-  # vapply(
-  #   seq_along(fa_df[["name"]]),
-  #   function(.i) {
-  #     # name <- fa_df[.i, "name"]
-  #     type <- fa_df[.i, "type"]
-  #     fa_json[[.i]][["svg"]][[type]][["raw"]]
-  #   },
-  #   character(1), USE.NAMES = FALSE
-  # ) -> fa_df[["glyph"]]
-  #
-  # fa_df[["unicode"]] <- as.character(
-  #   parse(text = shQuote(stringr::str_c('\\u', fa_df[["unicode"]])))
-  # )
-  #
-  # fa_df <- fa_df[complete.cases(fa_df),]
-  #
-  # return(fa_df)
-  #
-
-  return(readRDS(system.file("extdat/fadf.rds", package = "waffle")))
+  xdf <- readRDS(system.file("extdat/fadf.rds", package = "waffle"))
+  xdf[xdf[["type"]] != "regular", ]
 
 }
 
@@ -47,7 +16,7 @@
     vb,
     sprintf('%s width="24" height="24"', vb)
   ) -> fdf[["glyph"]]
-  DT::datatable(fdf, escape = FALSE)
+  DT::datatable(fdf[,c("name", "type", "glyph")], escape = FALSE)
 }
 
 #' Search Font Awesome glyph names for a pattern

R/geom-pictogram.R

@@ -0,0 +1,173 @@
+picto_scale <- function(aesthetic, values = NULL, ...) {
+
+  values <- if (is_missing(values)) "circle" else force(values)
+
+  pal <- function(n) {
+    vapply(
+      if (n > length(values)) rep(values[[1]], n) else values,
+      function(.x) .fa_unicode[.fa_unicode[["name"]] == .x, "unicode"],
+      character(1),
+      USE.NAMES = FALSE
+    )
+  }
+
+  discrete_scale(aesthetic, "manual", pal, ...)
+}
+
+#' Used with geom_pictogram() to map Font Awesome fonts to labels
+#'
+#' @param ... dots
+#' @param values values
+#' @param aesthetics aesthetics
+#' @export
+scale_label_pictogram <- function(..., values, aesthetics = "label") {
+  picto_scale(aesthetics, values, ...)
+}
+
+#' Legend builder for pictograms
+#'
+#' @param data,params,size legend key things
+#' @keywords internal
+#' @export
+draw_key_pictogram <- function(data, params, size) {
+
+  # msg("==> draw_key_pictogram()")
+  #
+  # print(str(data, 1))
+  # print(str(params, 1))
+
+  if (is.null(data$label)) data$label <- "a"
+
+  textGrob(
+    label = data$label,
+    x = 0.5, y = 0.5,
+    rot = data$angle %||% 0,
+    hjust = data$hjust %||% 0,
+    vjust = data$vjust %||% 0.5,
+    gp = gpar(
+      col = alpha(data$colour %||% data$fill %||% "black", data$alpha),
+      fontfamily = data$family %||% "",
+      fontface = data$fontface %||% 1,
+      fontsize = (data$size %||% 3.88) * .pt,
+      lineheight = 1.5
+    )
+  )
+}
+
+#' Pictogram Geom
+#'
+#' There are two special/critical `aes()` mappings:
+#' - `label` (so the geom knows which column to map the glyphs to)
+#' - `values` (which column you're mapping the filling for the squares with)
+#'
+#' @md
+#' @param mapping Set of aesthetic mappings created by `aes()` or
+#'   `aes_()`. If specified and `inherit.aes = TRUE` (the
+#'   default), it is combined with the default mapping at the top level of the
+#'   plot. You must supply `mapping` if there is no plot mapping.
+#' @param n_rows how many rows should there be in the waffle chart? default is 10
+#' @param flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols.
+#'     Useful to achieve waffle column chart effect. Defaults is `FALSE`.
+#' @param make_proportional compute proportions from the raw values? (i.e. each
+#'        value `n` will be replaced with `n`/`sum(n)`); default is `FALSE`.
+#' @param data The data to be displayed in this layer. There are three
+#'    options:
+#'
+#'    If `NULL`, the default, the data is inherited from the plot
+#'    data as specified in the call to `ggplot()`.
+#'
+#'    A `data.frame`, or other object, will override the plot
+#'    data. All objects will be fortified to produce a data frame. See
+#'    `fortify()` for which variables will be created.
+#'
+#'    A `function` will be called with a single argument,
+#'    the plot data. The return value must be a `data.frame.`, and
+#'    will be used as the layer data.
+#' @param na.rm If `FALSE`, the default, missing values are removed with
+#'   a warning. If `TRUE`, missing values are silently removed.
+#' @param show.legend logical. Should this layer be included in the legends?
+#'   `NA`, the default, includes if any aesthetics are mapped.
+#'   `FALSE` never includes, and `TRUE` always includes.
+#'   It can also be a named logical vector to finely select the aesthetics to
+#'   display.
+#' @param inherit.aes If `FALSE`, overrides the default aesthetics,
+#'   rather than combining with them. This is most useful for helper functions
+#'   that define both data and aesthetics and shouldn't inherit behaviour from
+#'   the default plot specification, e.g. `borders()`.
+#' @param ... other arguments passed on to `layer()`. These are
+#'   often aesthetics, used to set an aesthetic to a fixed value, like
+#'   `color = "red"` or `size = 3`. They may also be parameters
+#'   to the paired geom/stat.
+#' @export
+#' @export
+geom_pictogram <- function(mapping = NULL, data = NULL,
+                           n_rows = 10, make_proportional = FALSE, flip = FALSE,
+                           ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
+
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = "waffle",
+    geom = "pictogram",
+    position = "identity",
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      na.rm = na.rm,
+      n_rows = n_rows,
+      make_proportional = make_proportional,
+      flip = flip,
+      ...
+    )
+  )
+}
+
+#' @rdname geom_pictogram
+#' @export
+GeomPictogram <- ggplot2::ggproto(
+  `_class` = "GeomPictogram",
+  `_inherit` = GeomText,
+
+  #  required_aes = c("x", "y", "label", "colour"),
+
+  default_aes = aes(
+    fill = NA, alpha = NA, colour = "black",
+    size = 9, angle = 0, hjust = 0.5, vjust = 0.5,
+    family = "FontAwesome5Free-Solid", fontface = 1, lineheight = 1
+  ),
+
+
+  draw_group = function(self, data, panel_params, coord,
+                        n_rows = 10, make_proportional = FALSE, flip = FALSE,
+                        radius = grid::unit(0, "npc")) {
+
+    # msg("Called => GeomPictogram::draw_group()")
+
+    coord <- ggplot2::coord_equal()
+    grobs <- GeomText$draw_panel(data, panel_params, coord, parse = FALSE, check_overlap = FALSE)
+
+    # msg("Done With => GeomPictogram::draw_group()")
+
+    ggname("geom_pictogram", grid::grobTree(children = grobs))
+
+  },
+
+
+  draw_panel = function(self, data, panel_params, coord,
+                        n_rows = 10, make_proportional = FALSE, flip = FALSE, ...) {
+
+    # msg("Called => GeomPictogram::draw_panel()")
+    # print(str(data, 1))
+
+    coord <- ggplot2::coord_equal()
+    grobs <- GeomText$draw_panel(data, panel_params, coord, parse = FALSE, check_overlap = FALSE)
+
+    # msg("Done With => GeomPictogram::draw_panel()")
+
+    ggname("geom_pictogram", grid::grobTree(children = grobs))
+
+  },
+
+  draw_key = draw_key_pictogram
+
+)