Skip to content

Commit

Permalink
Merge pull request #269 from dreamRs/multi-geom
Browse files Browse the repository at this point in the history 
Multi geom mode
  • Loading branch information
@pvictor
pvictor authored Apr 16, 2024
2 parents 2e4297e + 9f3b69d commit 993d678
Show file tree
Hide file tree
Showing 23 changed files with 557 additions and 405 deletions.
3 changes: 3 additions & 0 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
163 changes: 78 additions & 85 deletions R/esquisse-server.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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) {

Expand All @@ -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, {
Expand Down Expand Up @@ -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)) {
Expand All @@ -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
Expand All @@ -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))
Expand Down
28 changes: 23 additions & 5 deletions R/esquisse-ui.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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)) {
Expand Down Expand Up @@ -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(
Expand All @@ -99,7 +109,6 @@ esquisse_ui <- function(id,
)
)
),

controls_ui(
id = ns("controls"),
insert_code = insert_code,
Expand Down Expand Up @@ -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),
Expand Down
21 changes: 13 additions & 8 deletions R/geometries.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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()`.
Expand Down Expand Up @@ -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"
}
}
Expand Down Expand Up @@ -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)
}
Expand All @@ -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",
Expand All @@ -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))
}
)

Expand All @@ -283,7 +288,7 @@ geomIcons <- function(geoms = NULL) {
)
}
)

geoms[!geoms %in% defaults] <- "blank"
list(names = geomsChoicesNames, values = geoms)
}

Loading

0 comments on commit 993d678

Please sign in to comment.