add seed param

DESCRIPTION

@@ -39,7 +39,8 @@ Imports:
     rlang,
     tidyr,
     ggrepel,
-    scales
+    scales,
+    withr (>= 2.5.0)
 Suggests:
     gridExtra,
     knitr,

NAMESPACE

@@ -39,6 +39,7 @@ importFrom(plotly,to_basic)
 importFrom(productplots,scale_x_product)
 importFrom(productplots,scale_y_product)
 importFrom(scales,alpha)
+importFrom(scales,censor)
 importFrom(tidyr,nest)
 importFrom(tidyr,unnest)
 importFrom(utils,getFromNamespace)

R/geom-mosaic-jitter.R

@@ -15,6 +15,8 @@
 #' }
 #' @param offset Set the space between the first spine
 #' @param drop_level Generate points for the max - 1 level
+#' @param seed Random seed passed to \code{\link[base]{set.seed}}. Defaults to
+#'   \code{NA}, which means that \code{set.seed} will not be called.
 #' @param na.rm If \code{FALSE} (the default), removes missing values with a warning. If \code{TRUE} silently removes missing values.
 #' @param ... other arguments passed on to \code{layer}. These are often aesthetics, used to set an aesthetic to a fixed value, like \code{color = 'red'} or \code{size = 3}. They may also be parameters to the paired geom/stat.
 #' @examples
@@ -41,7 +43,7 @@
 #'               divider = c("vspine", "hspine", "hspine"))
 geom_mosaic_jitter <- function(mapping = NULL, data = NULL, stat = "mosaic_jitter",
                                position = "identity", na.rm = FALSE,  divider = mosaic(),
-                               offset = 0.01, drop_level = FALSE,
+                               offset = 0.01, drop_level = FALSE, seed = NA,
                                show.legend = NA, inherit.aes = FALSE, ...)
 {
   if (!is.null(mapping$y)) {
@@ -129,6 +131,7 @@ geom_mosaic_jitter <- function(mapping = NULL, data = NULL, stat = "mosaic_jitte
       divider = divider,
       offset = offset,
       drop_level = drop_level,
+      seed = seed,
       ...
     )
   )

R/ggmosaic-package.R

@@ -5,6 +5,7 @@
 #' @importFrom productplots scale_x_product
 #' @importFrom productplots scale_y_product
 #' @importFrom scales alpha
+#' @importFrom scales censor
 #' @importFrom utils getFromNamespace
 ## usethis namespace: end
 NULL

R/scale-product.R

@@ -1,38 +1,3 @@
-is.formula <- function (x) inherits(x, "formula")
-
-is.discrete <- function(x) {
-  is.factor(x) || is.character(x) || is.logical(x)
-}
-
-product_names <- function() {
-  function(x) {
-    #cat(" in product_breaks\n")
-    #browser()
-    unique(x)
-  }
-}
-
-product_breaks <- function() {
-  function(x) {
-    #cat(" in product_breaks\n")
-    #browser()
-    unique(x)
-  }
-}
-
-product_labels <- function() {
-  function(x) {
-    #cat(" in product_labels\n")
-    #browser()
-
-    unique(x)
-  }
-}
-
-is.waive <- getFromNamespace("is.waive", "ggplot2")
-
-
-
 #' Helper function for determining scales
 #'
 #' Used internally to determine class of variable x
@@ -56,7 +21,7 @@ scale_type.productlist <- function(x) {
 #' @export
 scale_x_productlist <- function(name = ggplot2::waiver(), breaks = product_breaks(),
                                 minor_breaks = NULL, labels = product_labels(),
-                                limits = NULL, expand = ggplot2::waiver(), oob = scales:::censor,
+                                limits = NULL, expand = ggplot2::waiver(), oob = scales::censor,
                                 na.value = NA_real_, trans = "identity",
                                 position = "bottom", sec.axis = ggplot2::waiver()) {
   #browser()
@@ -83,7 +48,7 @@ scale_x_productlist <- function(name = ggplot2::waiver(), breaks = product_break
 #' @export
 scale_y_productlist <- function(name = ggplot2::waiver(), breaks = product_breaks(),
                                 minor_breaks = NULL, labels = product_labels(),
-                                limits = NULL, expand = ggplot2::waiver(), oob = scales:::censor,
+                                limits = NULL, expand = ggplot2::waiver(), oob = scales::censor,
                                 na.value = NA_real_, trans = "identity",
                                 position = "left", sec.axis = ggplot2::waiver()) {
   #browser()

R/stat-mosaic-jitter.r

@@ -1,26 +1,3 @@
-
-"%||%" <- function(a, b) {
-  if (!is.null(a)) a else b
-}
-
-in_data <- function(data, variable) {
-  length(intersect(names(data), variable)) > 0
-}
-
-parse_product_formula <- getFromNamespace("parse_product_formula", "productplots")
-
-#' Wrapper for a list
-#'
-#' @param ... Unquoted variables going into the product plot.
-#' @export
-#' @examples
-#' data(titanic)
-#' ggplot(data = titanic) +
-#'   geom_mosaic(aes(x = product(Survived, Class), fill = Survived))
-product <- function(...) {
-  rlang::exprs(...)
-}
-
 #' @rdname geom_mosaic_jitter
 #' @inheritParams ggplot2::stat_identity
 #' @section Computed variables:
@@ -34,7 +11,7 @@ product <- function(...) {
 stat_mosaic_jitter <- function(mapping = NULL, data = NULL, geom = "mosaic_jitter",
                                position = "identity", na.rm = FALSE,  divider = mosaic(),
                                show.legend = NA, inherit.aes = TRUE, offset = 0.01,
-                               drop_level = FALSE, ...)
+                               drop_level = FALSE, seed = NA, ...)
 {
   if (!is.null(mapping$y)) {
     stop("stat_mosaic() must not be used with a y aesthetic.", call. = FALSE)
@@ -106,6 +83,7 @@ stat_mosaic_jitter <- function(mapping = NULL, data = NULL, geom = "mosaic_jitte
       divider = divider,
       offset = offset,
       drop_level = drop_level,
+      seed = seed,
       ...
     )
   )
@@ -142,7 +120,7 @@ StatMosaicJitter <- ggplot2::ggproto(
     data
   },
 
-  compute_panel = function(self, data, scales, na.rm=FALSE, drop_level=FALSE, divider, offset) {
+  compute_panel = function(self, data, scales, na.rm=FALSE, drop_level=FALSE, seed = NA, divider, offset) {
     #cat("compute_panel from StatMosaic\n")
     #browser()
 
@@ -204,6 +182,7 @@ StatMosaicJitter <- ggplot2::ggproto(
     #   if ("ScaleContinuousProduct" %in% class(scales$y))
     #     res$y <- list(scale=scy)
     # }
+
     # XXXX add label for res
     cols <- c(prs$marg, prs$cond)
 
@@ -259,9 +238,16 @@ StatMosaicJitter <- ggplot2::ggproto(
 
 # create a set of uniformly spread points between 0 and 1 once, when the plot is created.
 # the transformation to the correct scale happens in compute panel.
+
+    # altered from ggrepel:
+    # Make reproducible if desired.
+    if (!is.null(seed) && is.na(seed)) {
+      seed <- sample.int(.Machine$integer.max, 1L)
+    }
+
     points <- subset(sub, sub$.n>=1)
     points <- tidyr::nest(points, data = -label)
-    points <-
+    points <- with_seed_null(seed,
       dplyr::mutate(
         points,
         coords = purrr::map(data, .f = function(d) {
@@ -271,7 +257,7 @@ StatMosaicJitter <- ggplot2::ggproto(
             dplyr::select(d, -x, -y)
           )
         })
-      )
+      ))
 
     points <- tidyr::unnest(points, coords)
     # browser()

R/stat-mosaic.r

@@ -1,26 +1,3 @@
-
-"%||%" <- function(a, b) {
-  if (!is.null(a)) a else b
-}
-
-in_data <- function(data, variable) {
-  length(intersect(names(data), variable)) > 0
-}
-
-parse_product_formula <- getFromNamespace("parse_product_formula", "productplots")
-
-#' Wrapper for a list
-#'
-#' @param ... Unquoted variables going into the product plot.
-#' @export
-#' @examples
-#' data(titanic)
-#' ggplot(data = titanic) +
-#'   geom_mosaic(aes(x = product(Survived, Class), fill = Survived))
-product <- function(...) {
-  rlang::exprs(...)
-}
-
 #' @rdname geom_mosaic
 #' @inheritParams ggplot2::stat_identity
 #' @section Computed variables:

R/utilities.R

@@ -0,0 +1,70 @@
+
+"%||%" <- function(a, b) {
+  if (!is.null(a)) a else b
+}
+
+in_data <- function(data, variable) {
+  length(intersect(names(data), variable)) > 0
+}
+
+parse_product_formula <- getFromNamespace("parse_product_formula", "productplots")
+
+#' Wrapper for a list
+#'
+#' @param ... Unquoted variables going into the product plot.
+#' @export
+#' @examples
+#' data(titanic)
+#' ggplot(data = titanic) +
+#'   geom_mosaic(aes(x = product(Survived, Class), fill = Survived))
+product <- function(...) {
+  rlang::exprs(...)
+}
+
+is.formula <- function (x) inherits(x, "formula")
+
+is.discrete <- function(x) {
+  is.factor(x) || is.character(x) || is.logical(x)
+}
+
+product_names <- function() {
+  function(x) {
+    #cat(" in product_breaks\n")
+    #browser()
+    unique(x)
+  }
+}
+
+product_breaks <- function() {
+  function(x) {
+    #cat(" in product_breaks\n")
+    #browser()
+    unique(x)
+  }
+}
+
+product_labels <- function() {
+  function(x) {
+    #cat(" in product_labels\n")
+    #browser()
+
+    unique(x)
+  }
+}
+
+is.waive <- getFromNamespace("is.waive", "ggplot2")
+
+
+
+
+## copied from ggplot2
+with_seed_null <- function(seed, code) {
+  if (is.null(seed)) {
+    code
+  } else {
+    withr::with_seed(seed, code)
+  }
+}
+
+
+

README.Rmd

@@ -6,7 +6,7 @@ editor_options:
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 
-```{r, echo = FALSE}
+```{r include = FALSE}
 knitr::opts_chunk$set(
   collapse = TRUE,
   comment = "#>",
@@ -15,20 +15,18 @@ knitr::opts_chunk$set(
 )
 ```
 
-# ggmosaic <img src="man/figures/logo.png" align="right" width="200"  style="vertical-align:top;margin:0px">
 <!-- badges: start -->
 [![CRAN Status](http://www.r-pkg.org/badges/version/ggmosaic)](https://cran.r-project.org/package=ggmosaic) [![CRAN RStudio mirror downloads](http://cranlogs.r-pkg.org/badges/ggmosaic)](https://www.r-pkg.org/pkg/ggmosaic) 
 [![R-CMD-check](https://github.com/haleyjeppson/ggmosaic/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/haleyjeppson/ggmosaic/actions/workflows/R-CMD-check.yaml)
 <!-- badges: end -->
-<br/>  
+
+# ggmosaic <img src="man/figures/logo.png" align="right" width="120" />
 
-## Overview
-
-**ggmosaic** was designed to create visualizations of categorical data and is capable of producing bar charts, stacked bar charts, mosaic plots, and double decker plots.
+ggmosaic was designed to create visualizations of categorical data and is capable of producing bar charts, stacked bar charts, mosaic plots, and double decker plots.
 
 ## Installation
 
-You can install **ggmosaic** from github with:
+You can install ggmosaic from github with:
 
 ```{r gh-installation, eval = FALSE}
 # install.packages("devtools")

inst/shiny/models/ui.R

@@ -79,8 +79,8 @@ shinyUI(
 
                )),
                fluidRow(
-               h5("Code output:"),
-               verbatimTextOutput("code"),
+               # h5("Code output:"),
+               # verbatimTextOutput("code"),
                br(),
                br(),
                br(),

inst/shiny/mosaics/server.R

@@ -6,7 +6,7 @@ library(tidyverse)
 library(DT)
 
 ## LOAD DATA
-# install_github("haleyjeppson/ggmosaic", ref = "data")
+# install_github("haleyjeppson/ggmosaic")
 data(happy, package = "ggmosaic")
 data(fly, package = "ggmosaic")
 data(titanic, package = "ggmosaic")