diff --git a/NAMESPACE b/NAMESPACE index cde1ca2b..a9d0ec43 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -39,6 +39,9 @@ importFrom(bslib,bs_add_rules) importFrom(bslib,bs_theme) importFrom(bslib,layout_sidebar) importFrom(bslib,nav_panel) +importFrom(bslib,nav_panel_hidden) +importFrom(bslib,nav_select) +importFrom(bslib,navset_hidden) importFrom(bslib,navset_pill) importFrom(bslib,sidebar) importFrom(datamods,filter_data_server) diff --git a/R/esquisse-server.R b/R/esquisse-server.R index b73deb33..7fb1354f 100644 --- a/R/esquisse-server.R +++ b/R/esquisse-server.R @@ -30,6 +30,7 @@ esquisse_server <- function(id, name = "data", default_aes = c("fill", "color", "size", "group", "facet"), import_from = c("env", "file", "copypaste", "googlesheets", "url"), + n_geoms = 8, drop_ids = TRUE, notify_warnings = NULL) { @@ -40,7 +41,6 @@ esquisse_server <- function(id, ns <- session$ns ggplotCall <- reactiveValues(code = "") data_chart <- reactiveValues(data = NULL, name = NULL) - geom_rv <- reactiveValues(possible = "auto", controls = "auto", palette = FALSE) # Settings modal (aesthetics choices) observeEvent(input$settings, { @@ -126,25 +126,34 @@ esquisse_server <- function(id, + ### Geom & aesthetics selection res_geom_aes_r <- select_geom_aes_server( id = "geomaes", data_r = reactive(data_chart$data), aesthetics_r = reactive(input$aesthetics), - geom_rv = geom_rv + n_geoms = n_geoms, + default_aes = default_aes ) aes_r <- reactive(res_geom_aes_r()$main$aes) - observeEvent(res_geom_aes_r()$geom_1, { - geom_rv$controls <- res_geom_aes_r()$main$geom + aes_others_r <- reactive({ + others <- res_geom_aes_r()$others + mappings <- others[grepl("aes", names(others))] + lapply(mappings, make_aes) }) + geom_r <- reactive(res_geom_aes_r()$main$geom) + geoms_others_r <- reactive({ + others <- res_geom_aes_r()$others + geoms <- others[grepl("geom", names(others))] + unlist(geoms, use.names = FALSE) + }) + - # Module chart controls : title, xlabs, colors, export... - # paramsChart <- reactiveValues(inputs = NULL) + ### Module chart controls : title, xlabs, colors, export... controls_rv <- controls_server( id = "controls", - type = geom_rv, - data_table = reactive(data_chart$data), + data_r = reactive(data_chart$data), data_name = reactive({ nm <- req(data_chart$name) if (is_call(nm)) { @@ -153,28 +162,17 @@ esquisse_server <- function(id, nm }), ggplot_rv = ggplotCall, - aesthetics = reactive({ - dropNullsOrEmpty(aes_r()) + geoms_r = reactive({ + c(geom_r(), geoms_others_r()) + }), + n_geoms = n_geoms, + active_geom_r <- reactive(res_geom_aes_r()$active), + aesthetics_r = reactive({ + c(list(aes_r()), aes_others_r()) }), use_facet = reactive({ !is.null(aes_r()$facet) | !is.null(aes_r()$facet_row) | !is.null(aes_r()$facet_col) }), - use_transX = reactive({ - if (is.null(aes_r()$xvar)) - return(FALSE) - identical( - x = col_type(data_chart$data[[aes_r()$xvar]]), - y = "continuous" - ) - }), - use_transY = reactive({ - if (is.null(aes_r()$yvar)) - return(FALSE) - identical( - x = col_type(data_chart$data[[aes_r()$yvar]]), - y = "continuous" - ) - }), width = reactive(rv_render_ggplot$plot_width), height = reactive(rv_render_ggplot$plot_height), drop_ids = drop_ids @@ -186,79 +184,74 @@ esquisse_server <- function(id, { req(input$play_plot, cancelOutput = TRUE) req(data_chart$data) - req(controls_rv$data) + data <- req(controls_rv$data) req(controls_rv$inputs) - geom_ <- req(res_geom_aes_r()$main$geom) + geom <- req(geom_r()) aes_input <- make_aes(aes_r()) - req(unlist(aes_input) %in% names(data_chart$data)) - mapping <- build_aes( data = data_chart$data, .list = aes_input, - geom = geom_ + geom = geom ) - geoms <- potential_geoms( - data = data_chart$data, - mapping = mapping - ) - req(geom_ %in% geoms) - - data <- controls_rv$data - - scales <- which_pal_scale( - mapping = mapping, - palette = controls_rv$colors$colors, - data = data, - reverse = controls_rv$colors$reverse - ) - - if (identical(geom_, "auto")) { - geom <- "blank" - } else { - geom <- geom_ - } - - geom_args <- match_geom_args( - geom_, - controls_rv$inputs, - mapping = mapping, - add_mapping = FALSE - ) - - if (isTRUE(controls_rv$smooth$add) & geom_ %in% c("point", "line")) { - geom <- c(geom, "smooth") - geom_args <- c( - setNames(list(geom_args), geom_), - list(smooth = controls_rv$smooth$args) + geoms <- potential_geoms(data_chart$data, mapping) + req(geom %in% geoms) + + + if (isTruthy(setdiff(geoms_others_r(), "blank"))) { + geom <- c(geom, geoms_others_r()) + mappings <- c(list(mapping), aes_others_r()) + # browser() + geom_args <- lapply( + X = seq_len(n_geoms), # n_geoms + FUN = function(i) { + match_geom_args( + geom[i], + controls_rv[[paste0("geomargs", i)]], + mapping = mappings[[i]], + add_mapping = i != 1 & length(mappings[[i]]) > 0, + exclude_args = names(combine_aes(mappings[[1]], mappings[[i]])) + ) + } ) - } - if (isTRUE(controls_rv$jitter$add) & geom_ %in% c("boxplot", "violin")) { - geom <- c(geom, "jitter") - geom_args <- c( - setNames(list(geom_args), geom_), - list(jitter = controls_rv$jitter$args) + blanks <- geom == "blank" + geom <- geom[!blanks] + geom_args[blanks] <- NULL + + scales_l <- dropNulls(lapply( + X = seq_len(n_geoms), + FUN = function(i) { + mapping <- mappings[[i]] + if (length(mapping) < 1) return(NULL) + which_pal_scale( + mapping = mapping, + palette = controls_rv[[paste0("geomcolors", i)]]$colors, + data = data, + reverse = controls_rv[[paste0("geomcolors", i)]]$reverse + ) + } + )) + scales_args <- unlist(lapply(scales_l, `[[`, "args"), recursive = FALSE) + scales <- unlist(lapply(scales_l, `[[`, "scales")) + } else { + geom_args <- match_geom_args( + geom, + controls_rv$geomargs1, + mapping = mapping, + add_mapping = FALSE ) - } - if (!is.null(aes_input$ymin) & !is.null(aes_input$ymax) & geom_ %in% c("line")) { - geom <- c("ribbon", geom) - mapping_ribbon <- aes_input[c("ymin", "ymax")] - geom_args <- c( - list(ribbon = list( - mapping = expr(aes(!!!syms2(mapping_ribbon))), - fill = controls_rv$inputs$color_ribbon - )), - setNames(list(geom_args), geom_) + scales <- which_pal_scale( + mapping = mapping, + palette = controls_rv$geomcolors1$colors, + data = data, + reverse = controls_rv$geomcolors1$reverse ) - mapping$ymin <- NULL - mapping$ymax <- NULL + scales_args <- scales$args + scales <- scales$scales } - scales_args <- scales$args - scales <- scales$scales - if (isTRUE(controls_rv$transX$use)) { scales <- c(scales, "x_continuous") scales_args <- c(scales_args, list(x_continuous = controls_rv$transX$args)) diff --git a/R/esquisse-ui.R b/R/esquisse-ui.R index 06a90ae6..f22ce57e 100644 --- a/R/esquisse-ui.R +++ b/R/esquisse-ui.R @@ -17,6 +17,7 @@ #' @param play_pause Display or not the play / pause button. #' @param layout_sidebar Put controls in a sidebar on the left rather than below the chart in dropdowns. #' @param downloads Export options available or `NULL` for no export. See [downloads_labels()]. +#' @param n_geoms Number of geoms the user can use. #' #' @return A `reactiveValues` with 3 slots : #' * **code_plot** : code to generate plot. @@ -48,7 +49,8 @@ esquisse_ui <- function(id, insert_code = FALSE, play_pause = TRUE, layout_sidebar = FALSE, - downloads = downloads_labels()) { + downloads = downloads_labels(), + n_geoms = 8) { ns <- NS(id) header_btns <- esquisse_header() if (is_list(header)) { @@ -84,8 +86,16 @@ esquisse_ui <- function(id, if (!isTRUE(layout_sidebar)) { tagList( - select_geom_aes_ui(ns("geomaes")), - + select_geom_aes_ui( + id = ns("geomaes"), + n_geoms = n_geoms, + list_geoms = c( + list(geomIcons()), + rep_len(list( + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "select") + ), n_geoms) + ) + ), fillCol( style = "overflow-y: auto;", tags$div( @@ -99,7 +109,6 @@ esquisse_ui <- function(id, ) ) ), - controls_ui( id = ns("controls"), insert_code = insert_code, @@ -129,7 +138,16 @@ esquisse_ui <- function(id, tags$div( class = "ggplot-geom-aes-container", - select_geom_aes_ui(ns("geomaes")), + select_geom_aes_ui( + id = ns("geomaes"), + n_geoms = n_geoms, + list_geoms = c( + list(geomIcons()), + rep_len(list( + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "select") + ), n_geoms) + ) + ), tags$div( class = "ggplot-output-sidebar-container", play_pause_input(ns("play_plot"), show = play_pause), diff --git a/R/geometries.R b/R/geometries.R index 230c7ddc..826c4669 100644 --- a/R/geometries.R +++ b/R/geometries.R @@ -167,6 +167,7 @@ potential_geoms_ref <- function() { #' @param add_aes Add aesthetics parameters (like size, fill, ...). #' @param mapping Mapping used in plot, to avoid setting fixed aesthetics parameters. #' @param add_mapping Add the mapping as an argument. +#' @param exclude_args Character vector of arguments to exclude, default is to exclude aesthetics names. #' @param envir Package environment to search in. #' #' @return a `list()`. @@ -194,12 +195,15 @@ match_geom_args <- function(geom, add_aes = TRUE, mapping = list(), add_mapping = FALSE, + exclude_args = NULL, envir = "ggplot2") { + if (is.null(exclude_args)) + exclude_args <- names(aes(!!!syms2(mapping))) if (!is.null(args$fill_color)) { if (geom %in% c("bar", "col", "histogram", "boxplot", "violin", "density", "ribbon")) { args$fill <- args$fill_color %||% "#0C4C8A" } - if (geom %in% c("line", "step", "path", "point")) { + if (geom %in% c("line", "step", "path", "point", "smooth")) { args$colour <- args$fill_color %||% "#0C4C8A" } } @@ -240,8 +244,8 @@ match_geom_args <- function(geom, geom_args <- c(geom_args, setNames(aes_args, aes_args)) } } - args <- args[names(args) %in% setdiff(names(geom_args), names(mapping))] - if (isTRUE(add_mapping)) + args <- args[names(args) %in% setdiff(names(geom_args), exclude_args)] + if (isTRUE(add_mapping) & length(mapping) > 0) args <- c(list(expr(aes(!!!syms2(mapping)))), args) return(args) } @@ -251,9 +255,10 @@ match_geom_args <- function(geom, # utils for geom icons -geomIcons <- function(geoms = NULL) { +geomIcons <- function(geoms = NULL, default = c("auto", "blank", "select")) { + default <- match.arg(default) defaults <- c( - "auto", "line", "step", "path", "area", "ribbon", + "line", "step", "path", "area", "ribbon", "bar", "col", "histogram", "density", "point", "jitter", "smooth", @@ -263,12 +268,12 @@ geomIcons <- function(geoms = NULL) { if (is.null(geoms)) geoms <- defaults geoms <- match.arg(geoms, defaults, several.ok = TRUE) - geoms <- unique(c("auto", geoms)) + geoms <- unique(c(default, geoms)) href <- "esquisse/geomIcon/gg-%s.png" geomsChoices <- lapply( X = geoms, FUN = function(x) { - list(inputId = x, img = sprintf(href, x), label = capitalize(x)) + list(inputId = x, img = sprintf(href, x), label = if (x != "select") capitalize(x)) } ) @@ -283,7 +288,7 @@ geomIcons <- function(geoms = NULL) { ) } ) - + geoms[!geoms %in% defaults] <- "blank" list(names = geomsChoicesNames, values = geoms) } diff --git a/R/ggcall.R b/R/ggcall.R index 791997c7..5827325f 100644 --- a/R/ggcall.R +++ b/R/ggcall.R @@ -21,21 +21,21 @@ #' #' @return a \code{call} that can be evaluated with \code{eval}. #' @export -#' +#' #' @importFrom stats setNames #' @importFrom rlang sym syms expr as_name is_call call2 has_length #' @importFrom ggplot2 ggplot aes theme facet_wrap vars coord_flip labs #' #' @example examples/ex-ggcall.R ggcall <- function(data = NULL, - mapping = NULL, - geom = NULL, + mapping = NULL, + geom = NULL, geom_args = list(), - scales = NULL, + scales = NULL, scales_args = list(), - coord = NULL, - labs = list(), - theme = NULL, + coord = NULL, + labs = list(), + theme = NULL, theme_args = list(), facet = NULL, facet_row = NULL, @@ -48,12 +48,12 @@ ggcall <- function(data = NULL, if (!is_call(data)) { data <- as.character(data) if (grepl("::", data)) { - data <- str2lang(data) + data <- str2lang(data) } else { data <- sym(data) } } - if (rlang::is_call(mapping)) + if (rlang::is_call(mapping)) mapping <- eval(mapping) mapping <- dropNulls(mapping) if (length(mapping) > 0) { @@ -63,17 +63,25 @@ ggcall <- function(data = NULL, ggcall <- expr(ggplot(!!data)) } if (length(geom) == 1) - geom_args <- setNames(list(geom_args), geom) - for (g in geom) { - g_args <- dropNulls(geom_args[[g]]) - if (!grepl("^geom_", g)) - g <- paste0("geom_", g) - geom <- call2(g, !!!g_args) - ggcall <- expr(!!ggcall + !!geom) + geom_args <- list(geom_args) + for (ig in seq_along(geom)) { + g_nm <- geom[ig] + if (ig <= length(geom_args)) { + g_args <- dropNulls(geom_args[[ig]]) + } else { + g_args <- list() + } + if (!grepl("^geom_", g_nm)) + g_nm <- paste0("geom_", g_nm) + geomcall <- call2(g_nm, !!!g_args) + ggcall <- expr(!!ggcall + !!geomcall) } if (!is.null(scales)) { if (length(scales) == 1 && !isTRUE(grepl(scales, names(scales_args)))) scales_args <- setNames(list(scales_args), scales) + scales_dup <- duplicated(scales, fromLast = TRUE) + scales_args <- scales_args[!scales_dup] + scales <- scales[!scales_dup] for (s in scales) { s_args <- dropNulls(scales_args[[s]]) if (grepl("::", x = s)) { @@ -138,7 +146,7 @@ ggcall <- function(data = NULL, ggcall <- expr(!!ggcall + !!facet) } } - + if (has_length(xlim, 2)) { xlim <- expr(xlim(!!!as.list(xlim))) ggcall <- expr(!!ggcall + !!xlim) @@ -147,7 +155,7 @@ ggcall <- function(data = NULL, ylim <- expr(ylim(!!!as.list(ylim))) ggcall <- expr(!!ggcall + !!ylim) } - + ggcall } diff --git a/R/mapping.R b/R/mapping.R index 49e83aa3..af9ab6a0 100644 --- a/R/mapping.R +++ b/R/mapping.R @@ -89,5 +89,10 @@ make_aes <- function(.list) { } - +combine_aes <- function(...) { + mapping <- c(...) + mapping <- mapping[!duplicated(names(mapping), fromLast = TRUE)] + mapping <- aes(!!!syms2(mapping)) + mapping[!duplicated(names(mapping), fromLast = TRUE)] +} diff --git a/R/module-controls-axes.R b/R/module-controls-axes.R index 51a596f5..74d778de 100644 --- a/R/module-controls-axes.R +++ b/R/module-controls-axes.R @@ -21,60 +21,13 @@ controls_axes_ui <- function(id) { ) tagList( - # tags$div( - # id = ns("controls-scatter"), - # style = "display: none; padding-top: 10px;", - # tags$label( - # class = "control-label", - # `for` = ns("smooth_add"), - # i18n("Add a smooth line:") - # ), - # prettyToggle( - # inputId = ns("smooth_add"), - # label_on = i18n("Yes"), - # status_on = "success", - # status_off = "danger", - # label_off = i18n("No"), - # inline = TRUE - # ), - # conditionalPanel( - # condition = paste0("input.smooth_add==true"), - # ns = ns, - # sliderInput( - # inputId = ns("smooth_span"), - # label = i18n("Smooth line span:"), - # min = 0.1, - # max = 1, - # value = 0.75, - # step = 0.01, - # width = "100%" - # ) - # ), - # ), - - # tags$div( - # id = ns("controls-jitter"), - # style = "display: none; padding-top: 10px;", - # tags$label( - # class = "control-label", - # `for` = ns("jitter_add"), - # i18n("Jittered points:") - # ), - # prettyToggle( - # inputId = ns("jitter_add"), - # label_on = i18n("Yes"), - # status_on = "success", - # status_off = "danger", - # label_off = i18n("No"), - # inline = TRUE - # ) - # ), input_axis_text("x", ns = ns), - input_axis_text("y", ns = ns), tags$div( - id = ns("controls-scale-trans-x"), style = "display: none;", + id = ns("controls-scale-trans-x"), + style = "display: none;", + tags$b("X", "axis options:"), numericRangeInput( inputId = ns("xlim"), label = i18n("X-Axis limits (empty for none):"), @@ -88,8 +41,14 @@ controls_axes_ui <- function(id) { width = "100%" ) ), + tags$hr(), + + input_axis_text("y", ns = ns), + tags$div( - id = ns("controls-scale-trans-y"), style = "display: none;", + id = ns("controls-scale-trans-y"), + style = "display: none;", + tags$b("Y", "axis options:"), numericRangeInput( inputId = ns("ylim"), label = i18n("Y-Axis limits (empty for none):"), @@ -103,17 +62,15 @@ controls_axes_ui <- function(id) { width = "100%" ) ), - tags$label( - class = "control-label", - `for` = ns("flip"), - i18n("Flip coordinate:") - ), - prettyToggle( - inputId = ns("flip"), - label_on = i18n("Yes"), - status_on = "success", - status_off = "danger", - label_off = i18n("No"), + tags$hr(), + tags$b("Coordinates system:"), + prettyRadioButtons( + inputId = ns("coordinates"), + label = "Coordinates:", + choiceNames = c("Cartesian", "Flip", "Fixed", "Polar"), + choiceValues = c("cartesian", "flip", "fixed", "polar"), + status = "primary", + outline = TRUE, inline = TRUE ) ) @@ -122,8 +79,7 @@ controls_axes_ui <- function(id) { controls_axes_server <- function(id, use_transX = reactive(FALSE), - use_transY = reactive(FALSE), - type = reactiveValues()) { + use_transY = reactive(FALSE)) { moduleServer( id = id, function(input, output, session) { @@ -139,23 +95,6 @@ controls_axes_server <- function(id, }) - - smooth_r <- reactive({ - list( - add = input$smooth_add, - args = list( - span = input$smooth_span - ) - ) - }) - - jitter_r <- reactive({ - list( - add = input$jitter_add, - args = list() - ) - }) - transX_r <- reactive({ list( use = use_transX() & !identical(input$transX, "identity"), @@ -175,7 +114,7 @@ controls_axes_server <- function(id, }) coord_r <- reactive( - if (isTRUE(input$flip)) "flip" else NULL + if (identical(input$coordinates, "cartesian")) NULL else input$coordinates ) limits_r <- reactive({ @@ -208,9 +147,7 @@ controls_axes_server <- function(id, return(list( inputs = inputs_r, - smooth = smooth_r, coord = coord_r, - jitter = jitter_r, transX = transX_r, transY = transY_r, limits = limits_r @@ -307,8 +244,7 @@ input_axis_text <- function(axis = c("x", "y"), ns = identity) { # step = 0.1, # width = "100%" # ) - ), - tags$hr() + ) ) } diff --git a/R/module-controls-geoms.R b/R/module-controls-geoms.R index 7ff57489..63144e9e 100644 --- a/R/module-controls-geoms.R +++ b/R/module-controls-geoms.R @@ -17,20 +17,12 @@ controls_geoms_ui <- function(id, style = NULL) { cols <- get_colors() pals <- get_palettes() - shape_names <- c( - "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet", - "square", paste("square", c("open", "filled", "cross", "plus", "triangle")), - "diamond", paste("diamond", c("open", "filled", "plus")), - "triangle", paste("triangle", c("open", "filled", "square")), - paste("triangle down", c("open", "filled")), - "plus", "cross", "asterisk" - ) - tags$div( class = "esquisse-controls-geoms-container", style = style, tags$div( - id = ns("controls-fill-color"), style = "display: block;", + id = ns("controls-fill-color"), + style = "display: block;", shinyWidgets::colorPickr( inputId = ns("fill_color"), label = i18n("Color:"), @@ -50,11 +42,13 @@ controls_geoms_ui <- function(id, style = NULL) { ) ), tags$div( - id = ns("controls-palette"), style = "display: none;", + id = ns("controls-palette"), + style = "display: none;", palette_ui(ns("colors")) ), tags$div( - id = ns("controls-ribbon-color"), style = "display: none;", + id = ns("controls-ribbon-color"), + style = "display: none;", colorPickr( inputId = ns("color_ribbon"), selected = "#A4A4A4", @@ -72,18 +66,77 @@ controls_geoms_ui <- function(id, style = NULL) { ) ), tags$div( - id = ns("controls-size"), style = "display: none;", + id = ns("controls-points"), + style = "display: none;", sliderInput( inputId = ns("size"), - label = i18n("Size for points/lines:"), + label = i18n("Size for points:"), min = 0.5, max = 5, - value = 1.2, + value = 1.5, + width = "100%" + ), + virtualSelectInput( + inputId = ns("shape"), + label = "Shape:", + choices = c( + "circle", paste("circle", c("open", "filled", "cross", "plus", "small")), "bullet", + "square", paste("square", c("open", "filled", "cross", "plus", "triangle")), + "diamond", paste("diamond", c("open", "filled", "plus")), + "triangle", paste("triangle", c("open", "filled", "square")), + paste("triangle down", c("open", "filled")), + "plus", "cross", "asterisk" + ), + width = "100%" + ) + ), + tags$div( + id = ns("controls-lines"), + style = "display: none;", + sliderInput( + inputId = ns("linewidth"), + label = i18n("Line width:"), + min = 0, + max = 3, + value = 0.5, + step = 0.05, + width = "100%" + ), + virtualSelectInput( + inputId = ns("linetype"), + label = "Line type:", + choices = setNames( + c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash"), + c("solid", "dashed", "dotted", "dotdash", "longdash", "twodash") + ), width = "100%" ) ), tags$div( - id = ns("controls-histogram"), style = "display: none;", + id = ns("controls-smooth"), + style = "display: none; padding-top: 10px;", + sliderInput( + inputId = ns("span"), + label = i18n("Controls the amount of smoothing:"), + min = 0.1, + max = 1, + value = 0.75, + step = 0.01, + width = "100%" + ), + sliderInput( + inputId = ns("level"), + label = i18n("Level of confidence interval to use:"), + min = 0.8, + max = 1, + value = 0.95, + step = 0.01, + width = "100%" + ) + ), + tags$div( + id = ns("controls-histogram"), + style = "display: none;", sliderInput( inputId = ns("bins"), label = i18n("Numbers of bins:"), @@ -94,7 +147,8 @@ controls_geoms_ui <- function(id, style = NULL) { ) ), tags$div( - id = ns("controls-violin"), style = "display: none;", + id = ns("controls-violin"), + style = "display: none;", prettyRadioButtons( inputId = ns("scale"), label = i18n("Scale:"), @@ -136,9 +190,9 @@ controls_geoms_ui <- function(id, style = NULL) { #' @importFrom shiny observeEvent observe req reactive bindEvent controls_geoms_server <- function(id, - data_table = reactive(NULL), - aesthetics = reactive(NULL), - type = reactiveValues()) { + data_r = reactive(NULL), + aesthetics_r = reactive(NULL), + geoms_r = reactive(NULL)) { moduleServer( id = id, function(input, output, session) { @@ -146,55 +200,46 @@ controls_geoms_server <- function(id, ns <- session$ns bindEvent(observe({ - aesthetics <- names(aesthetics()) - toggleDisplay("controls-position", type$controls %in% c("bar", "line", "area", "histogram") & "fill" %in% aesthetics) - toggleDisplay("controls-histogram", type$controls %in% "histogram") - toggleDisplay("controls-density", type$controls %in% c("density", "violin")) - toggleDisplay("controls-scatter", type$controls %in% "point") - toggleDisplay("controls-size", type$controls %in% c("point", "line", "step", "sf")) - toggleDisplay("controls-violin", type$controls %in% "violin") - toggleDisplay("controls-jitter", type$controls %in% c("boxplot", "violin")) - - if (type$controls %in% c("point")) { - updateSliderInput(session = session, inputId = "size", value = 1.5) - } else if (type$controls %in% c("line", "step")) { - updateSliderInput(session = session, inputId = "size", value = 0.5) - } - }), type$controls, aesthetics()) - - observeEvent(type$palette, { - toggleDisplay("controls-palette", display = isTRUE(type$palette)) - toggleDisplay("controls-fill-color", display = !isTRUE(type$palette)) - }) + aesthetics <- names(aesthetics_r()) + geom <- geoms_r() + toggleDisplay("controls-position", geom %in% c("bar", "line", "area", "histogram") & "fill" %in% aesthetics) + toggleDisplay("controls-histogram", geom %in% "histogram") + toggleDisplay("controls-density", geom %in% c("density", "violin")) + toggleDisplay("controls-smooth", geom %in% "smooth") + toggleDisplay("controls-points", geom %in% c("point")) + toggleDisplay("controls-lines", geom %in% c("line", "step")) + toggleDisplay("controls-violin", geom %in% "violin") + toggleDisplay("controls-jitter", geom %in% c("boxplot", "violin")) + }), geoms_r(), aesthetics_r()) - observe({ - req(aesthetics()) - aesthetics <- names(aesthetics()) - toggleDisplay("controls-shape", display = type$controls %in% "point" & !"shape" %in% aesthetics) + observeEvent(aesthetics_r(), { + aesthetics <- dropNullsOrEmpty(aesthetics_r()) + cond <- !is.null(aesthetics$fill) | !is.null(aesthetics$color) | !is.null(aesthetics$colour) + toggleDisplay("controls-palette", display = isTRUE(cond)) + toggleDisplay("controls-fill-color", display = !isTRUE(cond)) }) inputs_r <- reactive({ - aesthetics <- names(aesthetics()) + aesthetics <- names(aesthetics_r()) - shape <- input$shape - if (!(type$controls %in% "point" & !"shape" %in% aesthetics)) - shape <- NULL - - list( + dropNulls(list( adjust = input$adjust, position = input$position, - size = input$size, - linewidth = input$size, + size = if (!identical(input$size, 1.5)) input$size, + linewidth = if (!identical(input$linewidth, 0.5)) input$linewidth, + linetype = if (!identical(input$linetype, "solid")) input$linetype, fill_color = input$fill_color, color_ribbon = input$color_ribbon, - shape = shape - ) + shape = if (!identical(input$shape, "circle")) input$shape, + span = if (!identical(input$span, 0.75)) input$span, + level = if (!identical(input$level, 0.95)) input$level + )) }) # Colors input colors_r <- palette_server("colors", reactive({ - data_ <- data_table() - aesthetics_ <- aesthetics() + data_ <- data_r() + aesthetics_ <- aesthetics_r() if ("fill" %in% names(aesthetics_)) { return(data_[[aesthetics_$fill]]) } @@ -205,9 +250,92 @@ controls_geoms_server <- function(id, })) colors_r_d <- debounce(colors_r, millis = 1000) - return(list(inputs = inputs_r, colors = colors_r_d)) + return(reactive(list(inputs = inputs_r(), colors = colors_r_d()))) } ) } + +# Multi geoms ------------------------------------------------------------- + +#' @importFrom bslib navset_hidden nav_panel_hidden +controls_multigeoms_ui <- function(id, style = NULL, n_geoms = 1) { + ns <- NS(id) + if (n_geoms == 1) { + controls_geoms_ui(ns("geom1"), style = style) + } else { + navs_controls_geom <- lapply( + X = seq_len(n_geoms), + FUN = function(i) { + nav_panel_hidden( + value = paste0("geom", i), + controls_geoms_ui(ns(paste0("geom", i)), style = style) + ) + } + ) + navset_hidden( + id = ns("navset_controls_geoms"), + !!!navs_controls_geom + ) + } +} + + +#' @importFrom bslib nav_select +#' @importFrom shiny moduleServer observeEvent reactiveValues reactive +controls_multigeoms_server <- function(id, + data_r = reactive(NULL), + aesthetics_r = reactive(NULL), + geoms_r = reactive(NULL), + n_geoms = 1, + active_geom_r = reactive("geom1")) { + moduleServer( + id = id, + function(input, output, session) { + + observeEvent(active_geom_r(), { + nav_select(id = "navset_controls_geoms", selected = active_geom_r()) + }) + + rv <- reactiveValues() + + lapply( + X = seq_len(n_geoms), + FUN = function(i) { + + res_r <- controls_geoms_server( + id = paste0("geom", i), + data_r = data_r, + aesthetics_r = reactive({ + combine_aes(aesthetics_r()[[1]], aesthetics_r()[[i]]) + }), + geoms_r = reactive({ + geoms_r()[i] + }) + ) + + observeEvent(res_r(), { + rv[[paste0("geom", i)]] <- res_r() + }) + + } + ) + + return(reactive({ + lapply( + X = seq_len(n_geoms), + FUN = function(i) { + list( + inputs = rv[[paste0("geom", i)]]$inputs, + colors = rv[[paste0("geom", i)]]$colors + ) + } + ) + })) + } + ) +} + + + diff --git a/R/module-controls-labs.R b/R/module-controls-labs.R index 4b02f8f0..69aef737 100644 --- a/R/module-controls-labs.R +++ b/R/module-controls-labs.R @@ -66,8 +66,8 @@ controls_labs_ui <- function(id) { controls_labs_server <- function(id, - data_table = reactive(NULL), - aesthetics = reactive(NULL)) { + data_r = reactive(NULL), + aesthetics_r = reactive(NULL)) { moduleServer( id = id, function(input, output, session) { @@ -75,7 +75,7 @@ controls_labs_server <- function(id, ns <- session$ns # Reset labs ---- - observeEvent(data_table(), { + observeEvent(data_r(), { updateTextInput(session = session, inputId = "labs_title", value = character(0)) updateTextInput(session = session, inputId = "labs_subtitle", value = character(0)) updateTextInput(session = session, inputId = "labs_caption", value = character(0)) @@ -88,19 +88,18 @@ controls_labs_server <- function(id, }) # display specific control according to aesthetics set - observeEvent(aesthetics(), { - aesthetics <- names(aesthetics()) + observeEvent(aesthetics_r(), { + aesthetics <- names(aesthetics_r()) toggleDisplay("controls-labs-fill", display = "fill" %in% aesthetics) toggleDisplay("controls-labs-color", display = "color" %in% aesthetics) toggleDisplay("controls-labs-size", display = "size" %in% aesthetics) toggleDisplay("controls-labs-shape", display = "shape" %in% aesthetics) - toggleDisplay("controls-ribbon-color", display = "ymin" %in% aesthetics) }) # labs input labs_r <- debounce(reactive({ - asth <- names(aesthetics()) + asth <- names(aesthetics_r()) labs_fill <- `if`(isTRUE("fill" %in% asth), input$labs_fill, "") labs_color <- `if`(isTRUE("color" %in% asth), input$labs_color, "") labs_size <- `if`(isTRUE("size" %in% asth), input$labs_size, "") diff --git a/R/module-controls-theme.R b/R/module-controls-theme.R index 28abe9f1..21430593 100644 --- a/R/module-controls-theme.R +++ b/R/module-controls-theme.R @@ -36,19 +36,14 @@ controls_theme_ui <- function(id, style = NULL) { #' @importFrom shiny observeEvent observe req reactive -controls_theme_server <- function(id, - data_table = reactive(NULL), - aesthetics = reactive(NULL), - type = reactiveValues()) { +controls_theme_server <- function(id) { moduleServer( id = id, function(input, output, session) { ns <- session$ns - inputs_r <- reactive({ - aesthetics <- names(aesthetics()) legend_position <- input$legend_position if (identical(legend_position, "right")) diff --git a/R/module-controls.R b/R/module-controls.R index 49cc748c..418b9b04 100644 --- a/R/module-controls.R +++ b/R/module-controls.R @@ -138,7 +138,7 @@ controls_ui <- function(id, } if (isTRUE("geoms" %in% controls)) { listControls[[length(listControls) + 1]] <- funControl( - controls_geoms_ui( + controls_multigeoms_ui( ns("geoms"), style = if (layout == "dropdown") { css( @@ -147,7 +147,8 @@ controls_ui <- function(id, overflowX = "hidden", padding = "5px 7px" ) - } + }, + n_geoms = 5 ), inputId = ns("controls-geoms"), class = "esquisse-controls-geoms", @@ -242,16 +243,12 @@ controls_ui <- function(id, #' #' @param id Module's ID. #' @param type \code{reactiveValues} indicating the type of chart. -#' @param data_table \code{reactive} function returning data used in plot. +#' @param data_r \code{reactive} function returning data used in plot. #' @param data_name \code{reactive} function returning data name. #' @param ggplot_rv \code{reactiveValues} with ggplot object (for export). #' @param aesthetics \code{reactive} function returning aesthetic names used. #' @param use_facet \code{reactive} function returning #' \code{TRUE} / \code{FALSE} if plot use facets. -#' @param use_transX \code{reactive} function returning \code{TRUE} / \code{FALSE} -#' to use transformation on x-axis. -#' @param use_transY \code{reactive} function returning \code{TRUE} / \code{FALSE} -#' to use transformation on y-axis. #' #' @return A reactiveValues with all input's values #' @noRd @@ -263,14 +260,14 @@ controls_ui <- function(id, #' @importFrom datamods filter_data_server #' controls_server <- function(id, - type, - data_table, + data_r, data_name, ggplot_rv, - aesthetics = reactive(NULL), + geoms_r = reactive(NULL), + active_geom_r = reactive("geom1"), + n_geoms = 1, + aesthetics_r = reactive(NULL), use_facet = reactive(FALSE), - use_transX = reactive(FALSE), - use_transY = reactive(FALSE), width = reactive(NULL), height = reactive(NULL), drop_ids = TRUE) { @@ -289,29 +286,45 @@ controls_server <- function(id, labs_r <- controls_labs_server( id = "labs", - data_table = data_table, - aesthetics = aesthetics + data_r = data_r, + aesthetics_r = reactive(aesthetics_r()[[1]]) ) - geometries_r <- controls_geoms_server( + geometries_r <- controls_multigeoms_server( id = "geoms", - data_table = data_table, - aesthetics = aesthetics, - type = type + data_r = data_r, + aesthetics_r = aesthetics_r, + geoms_r = geoms_r, + n_geoms = n_geoms, + active_geom_r = active_geom_r ) theme_r <- controls_theme_server( - id = "theme", - data_table = data_table, - aesthetics = aesthetics, - type = type + id = "theme" ) axes_r <- controls_axes_server( id = "axes", - use_transX = use_transX, - use_transY = use_transY, - type = type + use_transX = reactive({ + data <- req(data_r()) + aes1 <- aesthetics_r()[[1]] + if (is.null(aes1$xvar)) + return(FALSE) + identical( + x = col_type(data[[aes1$xvar]]), + y = "continuous" + ) + }), + use_transY = reactive({ + data <- req(data_r()) + aes1 <- aesthetics_r()[[1]] + if (is.null(aes1$yvar)) + return(FALSE) + identical( + x = col_type(data[[aes1$yvar]]), + y = "continuous" + ) + }) ) controls_export_server( @@ -334,12 +347,12 @@ controls_server <- function(id, output_filter <- filter_data_server( id = "filter-data", data = reactive({ - req(data_table()) - req(names(data_table())) + req(data_r()) + req(names(data_r())) if (isTRUE(input$disable_filters)) { return(NULL) } else { - data_table() + data_r() } }), name = data_name, @@ -354,14 +367,21 @@ controls_server <- function(id, export_png = NULL ) - observeEvent(data_table(), { - outputs$data <- data_table() + observeEvent(data_r(), { + outputs$data <- data_r() outputs$code <- reactiveValues(expr = NULL, dplyr = NULL) }) - observeEvent(geometries_r$inputs(), { - outputs$inputs <- modifyList(outputs$inputs, geometries_r$inputs()) + observeEvent(geometries_r(), { + res <- geometries_r() + lapply( + X = seq_len(n_geoms), + FUN = function(i) { + outputs[[paste0("geomargs", i)]] <- res[[i]]$inputs + outputs[[paste0("geomcolors", i)]] <- res[[i]]$colors + } + ) }) observeEvent(theme_r$inputs(), { @@ -377,11 +397,6 @@ controls_server <- function(id, }) - observeEvent(geometries_r$colors(), { - outputs$colors <- geometries_r$colors() - }) - - # theme input observe({ theme_labs <- labs_r$theme() @@ -411,16 +426,6 @@ controls_server <- function(id, outputs$coord <- axes_r$coord() }, ignoreNULL = FALSE) - # # smooth input - # observeEvent(axes_r$smooth(), { - # outputs$smooth <- parameters_r$smooth() - # }) - # - # # jittered input - # observeEvent(axes_r$jitter(), { - # outputs$jitter <- parameters_r$jitter() - # }) - # transX input observeEvent(axes_r$transX(), { outputs$transX <- axes_r$transX() diff --git a/R/module-select-aes.R b/R/module-select-aes.R index c5c94b0f..087b3cbb 100644 --- a/R/module-select-aes.R +++ b/R/module-select-aes.R @@ -25,7 +25,7 @@ select_aes_server <- function(id, if (is.reactive(default_aes)) { aesthetics <- default_aes() } else { - if (is.null(input_aes())) { + if (length(input_aes()) < 1) { aesthetics <- default_aes } else { aesthetics <- input_aes() diff --git a/R/module-select-geom-aes.R b/R/module-select-geom-aes.R index ebf35719..96fcaaec 100644 --- a/R/module-select-geom-aes.R +++ b/R/module-select-geom-aes.R @@ -33,7 +33,8 @@ select_geom_aes_ui <- function(id, n_geoms = 1, list_geoms = NULL) { X = seq_len(n_geoms), FUN = function(i) { nav_panel( - paste0("Geom #", i), + title = paste0("Geom #", i), + value = paste0("geom", i), tags$div( class = "esquisse-geom-aes", tags$div( @@ -66,13 +67,26 @@ select_geom_aes_server <- function(id, n_geoms = 1, data_r = reactive(NULL), default_aes = c("fill", "color", "size", "group", "facet"), - aesthetics_r = reactive(NULL), - geom_rv = reactiveValues()) { + aesthetics_r = reactive(NULL)) { moduleServer( id, function(input, output, session) { rv <- reactiveValues() + lapply( + X = seq_len(n_geoms), + FUN = function(i) { + rv[[paste0("aes_", i)]] <- list() + rv[[paste0("geom_", i)]] <- NA_character_ + } + ) + + # special case: geom_sf + observeEvent(data_r(), { + if (inherits(data_r(), what = "sf")) { + geom_rv$possible <- c("sf", geom_rv$possible) + } + }) lapply( X = seq_len(n_geoms), @@ -81,69 +95,74 @@ select_geom_aes_server <- function(id, aes_r <- select_aes_server( id = paste0("aes_", i), data_r = data_r, - default_aes = default_aes, - input_aes = aesthetics_r + default_aes = if (i > 1) { + grep("facet", x = default_aes, value = TRUE, invert = TRUE) + } else { + default_aes + }, + input_aes = reactive({ + aesth <- aesthetics_r() + if (i > 1) { + aesth <- grep("facet", x = aesth, value = TRUE, invert = TRUE) + } + aesth + }) ) observeEvent(aes_r(), { - rv[[paste0("aes_", i)]] <- aes_r() - }) - - # special case: geom_sf - observeEvent(data_r(), { - if (inherits(data_r(), what = "sf")) { - geom_rv$possible <- c("sf", geom_rv$possible) - } - }) - - bindEvent(observe({ - aesthetics <- rv[[paste0("aes_", i)]] - data <- data_r() - geoms <- potential_geoms( - data = data, - mapping = build_aes( - data = data, - # x = aesthetics$xvar, - # y = aesthetics$yvar - .list = aesthetics - ) - ) - - if (i == 1) { - geom_rv$possible <- c("auto", geoms) - geom_rv$controls <- select_geom_controls(input[[paste0("geom_", i)]], geoms) - geom_rv$palette <- !is.null(aesthetics$fill) | !is.null(aesthetics$color) - } - rv[[paste0("geom_possible", i)]] <- c("auto", geoms) - - - }), rv[[paste0("aes_", i)]], input[[paste0("geom_", i)]]) - - observeEvent(rv[[paste0("geom_possible", i)]], { - geoms <- geomIcons()$values - geomposs <- rv[[paste0("geom_possible", i)]] - updateDropInput( - session = session, - inputId = paste0("geom_", i), - selected = setdiff(geomposs, "auto")[1], - disabled = setdiff(geoms, geomposs) - ) + rv[[paste0("aes_", i)]] <- dropNulls(aes_r()) }) observeEvent(input[[paste0("geom_", i)]], { rv[[paste0("geom_", i)]] <- input[[paste0("geom_", i)]] }) + } ) + + bindEvent(observe({ + aesthetics <- rv$aes_1 + data <- data_r() + geoms <- potential_geoms( + data = data, + mapping = build_aes( + data = data, + .list = aesthetics + ) + ) + + if (inherits(data_r(), "sf")) { + geoms <- c(geoms, "sf") + } + + rv$possible <- c("auto", geoms) + + }), rv$aes_1, input$geom_1) + + observeEvent( rv$possible, { + geoms <- geomIcons()$values + geomposs <- rv$possible + updateDropInput( + session = session, + inputId = "geom_1", + selected = setdiff(geomposs, "auto")[1], + disabled = setdiff(geoms, geomposs) + ) + }) + + return(reactive({ others <- reactiveValuesToList(rv) others$aes_1 <- NULL others$geom_1 <- NULL - others[vapply(others, FUN = identical, "auto", FUN.VALUE = logical(1))] <- NULL + others$possible <- NULL + # others[vapply(others, FUN = identical, "auto", FUN.VALUE = logical(1))] <- NULL + # others[vapply(others, FUN = identical, "blank", FUN.VALUE = logical(1))] <- NULL + others[grepl("geom_possible", names(others))] <- NULL result <- list( main = list(aes = rv$aes_1, geom = rv$geom_1), - others = dropNullsOrEmpty(others) + others = others ) result$active <- input$navset_geoms return(result) diff --git a/R/scales.R b/R/scales.R index 348f5d3f..3bc448dd 100644 --- a/R/scales.R +++ b/R/scales.R @@ -11,51 +11,52 @@ #' #' @return a \code{list} #' @export -#' +#' #' @importFrom ggplot2 scale_fill_hue scale_color_hue scale_fill_gradient scale_color_gradient #' scale_fill_brewer scale_color_brewer scale_fill_distiller scale_color_distiller #' scale_fill_viridis_c scale_color_viridis_c scale_fill_viridis_d scale_color_viridis_d #' @importFrom rlang is_named -#' +#' #' @examples #' library(ggplot2) -#' +#' #' # Automatic guess according to data #' which_pal_scale( -#' mapping = aes(fill = Sepal.Length), -#' palette = "ggplot2", +#' mapping = aes(fill = Sepal.Length), +#' palette = "ggplot2", #' data = iris #' ) #' which_pal_scale( #' mapping = aes(fill = Species), -#' palette = "ggplot2", +#' palette = "ggplot2", #' data = iris #' ) -#' -#' +#' +#' #' # Explicitly specify type #' which_pal_scale( -#' mapping = aes(color = variable), -#' palette = "Blues", +#' mapping = aes(color = variable), +#' palette = "Blues", #' color_type = "discrete" #' ) -#' -#' +#' +#' #' # Both scales #' which_pal_scale( -#' mapping = aes(color = var1, fill = var2), -#' palette = "Blues", +#' mapping = aes(color = var1, fill = var2), +#' palette = "Blues", #' color_type = "discrete", #' fill_type = "continuous" #' ) -which_pal_scale <- function(mapping, - palette = "ggplot2", +which_pal_scale <- function(mapping, + palette = "ggplot2", data = NULL, - fill_type = c("continuous", "discrete"), + fill_type = c("continuous", "discrete"), color_type = c("continuous", "discrete"), reverse = FALSE) { if (length(palette) < 1) return(list()) + mapping <- aes(!!!syms2(mapping)) args <- list() fill_type <- match.arg(fill_type) color_type <- match.arg(color_type) @@ -72,7 +73,7 @@ which_pal_scale <- function(mapping, color_type <- "continuous" } } - + # Option 1: manual color palette if (rlang::is_named(palette)) { if (!is.null(mapping$fill)) { @@ -108,7 +109,7 @@ which_pal_scale <- function(mapping, args = args )) } - + # Option 2: known palette palettes <- unlist(lapply(default_pals()$choices, names), recursive = TRUE, use.names = FALSE) if (isTRUE(palette %in% palettes)) { @@ -156,7 +157,7 @@ which_pal_scale <- function(mapping, ) if (!identical(palette, "ggplot2")) { args[[fill_scale]] <- setNames( - object = list(palette), + object = list(palette), nm = ifelse(grepl("viridis", fill_scale), "option", "palette") ) if (palette %in% c("ipsum", "ft")) { @@ -180,7 +181,7 @@ which_pal_scale <- function(mapping, ) if (!identical(palette, "ggplot2")) { args[[color_scale]] <- setNames( - object = list(palette), + object = list(palette), nm = ifelse(grepl("viridis", color_scale), "option", "palette") ) if (palette %in% c("ipsum", "ft")) { @@ -201,7 +202,7 @@ which_pal_scale <- function(mapping, args = args )) } - + # Option 3: custom palette palettes <- get_palettes()$choices if (isTRUE(palette %in% names(palettes))) { diff --git a/examples/select-geom-aes.R b/examples/select-geom-aes.R index acdc3aae..f8bf7567 100644 --- a/examples/select-geom-aes.R +++ b/examples/select-geom-aes.R @@ -11,12 +11,13 @@ ui <- fluidPage( # select_geom_aes_ui("myid", n_geoms = 1), select_geom_aes_ui( "myid", - n_geoms = 4, + n_geoms = 5, list_geoms = list( geomIcons(), - geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin")), - geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin")), - geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin")) + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "blank"), + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "blank"), + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "blank"), + geomIcons(c("line", "step", "jitter", "point", "smooth", "density", "boxplot", "violin"), default = "blank") ) ), verbatimTextOutput("result") @@ -26,7 +27,7 @@ server <- function(input, output, session) { res_r <- select_geom_aes_server( id = "myid", - n_geoms = 4, + n_geoms = 5, data_r = reactive(palmerpenguins::penguins) # data_r = reactive(apexcharter::temperatures) ) diff --git a/inst/assets/geomIcon/gg-blank.png b/inst/assets/geomIcon/gg-blank.png new file mode 100644 index 00000000..34fe286b Binary files /dev/null and b/inst/assets/geomIcon/gg-blank.png differ diff --git a/inst/assets/geomIcon/gg-select.png b/inst/assets/geomIcon/gg-select.png new file mode 100644 index 00000000..d8fa4cfa Binary files /dev/null and b/inst/assets/geomIcon/gg-select.png differ diff --git a/inst/geomIcon/iconGeom.R b/inst/geomIcon/iconGeom.R index 8c39d814..cb9e7629 100644 --- a/inst/geomIcon/iconGeom.R +++ b/inst/geomIcon/iconGeom.R @@ -256,6 +256,35 @@ dev.off() +# Geom blank -------------------------------------------------------------- + +png(filename = "inst/geomIcon/www/gg-blank.png", bg = "transparent") +ggplot() + + geom_polygon(data = coord_circle(centre = c(0, 0), r = 1), aes(x = x, y = y), fill = "#FFFFFF", color = "#000000") + + coord_fixed() + + geom_text(mapping = aes(x = 0, y = 0, label = "blank"), color = "#000000", size = 50) + + theme_void() +# p <- ggplot() + geom_text(mapping = aes(x = 0, y = 0, label = "blank"), color = "#000000", size = 50) + theme_void() +# print(p, vp = viewport(width = unit(0.6, "npc"), height = unit(0.6, "npc"))) +dev.off() + + + +# Geom select -------------------------------------------------------------- + +png(filename = "inst/geomIcon/www/gg-select.png", bg = "transparent") +ggplot() + + geom_polygon(data = coord_circle(centre = c(0, 0), r = 1), aes(x = x, y = y), fill = "#FFFFFF", color = "#FFFFFF") + + coord_fixed() + + geom_text(mapping = aes(x = 0, y = 0, label = "select\ngeom"), color = "#000000", size = 46) + + theme_void() +# p <- ggplot() + geom_text(mapping = aes(x = 0, y = 0, label = "blank"), color = "#000000", size = 50) + theme_void() +# print(p, vp = viewport(width = unit(0.6, "npc"), height = unit(0.6, "npc"))) +dev.off() + + + + # Geom tile --------------------------------------------------------------- png(filename = "inst/geomIcon/www/gg-tile.png", bg = "transparent") diff --git a/inst/geomIcon/www/gg-blank.png b/inst/geomIcon/www/gg-blank.png new file mode 100644 index 00000000..34fe286b Binary files /dev/null and b/inst/geomIcon/www/gg-blank.png differ diff --git a/inst/geomIcon/www/gg-select.png b/inst/geomIcon/www/gg-select.png new file mode 100644 index 00000000..d8fa4cfa Binary files /dev/null and b/inst/geomIcon/www/gg-select.png differ diff --git a/man/esquisse-module.Rd b/man/esquisse-module.Rd index 6daef347..f38b1404 100644 --- a/man/esquisse-module.Rd +++ b/man/esquisse-module.Rd @@ -16,7 +16,8 @@ esquisse_ui( insert_code = FALSE, play_pause = TRUE, layout_sidebar = FALSE, - downloads = downloads_labels() + downloads = downloads_labels(), + n_geoms = 8 ) esquisse_server( @@ -25,6 +26,7 @@ esquisse_server( name = "data", default_aes = c("fill", "color", "size", "group", "facet"), import_from = c("env", "file", "copypaste", "googlesheets", "url"), + n_geoms = 8, drop_ids = TRUE, notify_warnings = NULL ) @@ -62,6 +64,8 @@ code in the current user script (work only in RStudio).} \item{downloads}{Export options available or \code{NULL} for no export. See \code{\link[=downloads_labels]{downloads_labels()}}.} +\item{n_geoms}{Number of geoms the user can use.} + \item{data_rv}{Either: \itemize{ \item A \code{\link[shiny:reactiveValues]{shiny::reactiveValues()}} with a slot \code{data} containing a \code{data.frame} diff --git a/man/match_geom_args.Rd b/man/match_geom_args.Rd index 20d504a9..5ce35bb5 100644 --- a/man/match_geom_args.Rd +++ b/man/match_geom_args.Rd @@ -10,6 +10,7 @@ match_geom_args( add_aes = TRUE, mapping = list(), add_mapping = FALSE, + exclude_args = NULL, envir = "ggplot2" ) } @@ -24,6 +25,8 @@ match_geom_args( \item{add_mapping}{Add the mapping as an argument.} +\item{exclude_args}{Character vector of arguments to exclude, default is to exclude aesthetics names.} + \item{envir}{Package environment to search in.} } \value{ diff --git a/man/which_pal_scale.Rd b/man/which_pal_scale.Rd index d6f7784c..8b744573 100644 --- a/man/which_pal_scale.Rd +++ b/man/which_pal_scale.Rd @@ -37,29 +37,29 @@ library(ggplot2) # Automatic guess according to data which_pal_scale( - mapping = aes(fill = Sepal.Length), - palette = "ggplot2", + mapping = aes(fill = Sepal.Length), + palette = "ggplot2", data = iris ) which_pal_scale( mapping = aes(fill = Species), - palette = "ggplot2", + palette = "ggplot2", data = iris ) # Explicitly specify type which_pal_scale( - mapping = aes(color = variable), - palette = "Blues", + mapping = aes(color = variable), + palette = "Blues", color_type = "discrete" ) # Both scales which_pal_scale( - mapping = aes(color = var1, fill = var2), - palette = "Blues", + mapping = aes(color = var1, fill = var2), + palette = "Blues", color_type = "discrete", fill_type = "continuous" )