layerPositionUI <- function(id) {
ns <- NS(id)
tagList(
uiOutput(ns('position_chooser')),
uiOutput(ns('position_options')),
uiOutput(ns('position_sub_options'))
)
}
#' Server function for position arguments
#'
#' @param input Shiny inputs
#' @param output Shiny outputs
#' @param session Shiny user session
#' @param base_data Pre-isolated reactive to base layer data
#' @param default_position Default layer position
#'
#' @importFrom magrittr %>%
#' @import shiny ggplot2
#'
layerPositionServer <- function(input, output, session, base_data, default_position) {
positions <- c("identity", "jitter", "dodge", "dodge2", "jitterdodge", "nudge", "stack", "fill")
# Need a reactive trigger to fix a shinyWidgets bug
refreshWidget <- makeReactiveTrigger()
# Sub-positions that share settings
pos_to_sub <- list(
"dodge" = "dodge2",
"stack" = "fill"
)
sub_to_pos <- as.list(names(pos_to_sub))
names(sub_to_pos) <- purrr::flatten_chr(pos_to_sub)
# Load position server code (if present)
# Note that for now all _server function need the additional argument refreshWidget
# Can remove once bug in shinyWidgets is addressed
purrr::map(positions, ~ tryCatch(
do.call(paste0(.,'_server'),
list(session = session, refreshWidget = refreshWidget)),
error = function(e) NULL)
)
output$position_chooser <- renderUI({
init_position <- input$position %||% sub_to_pos[[default_position]] %||% default_position
isolate({
tagList(
selectizeInput(session$ns('position'),
label = NULL,
choices = list("Identity" = "identity",
"Jitter" = "jitter",
"Dodge" = "dodge",
"Jitter-Dodge" = "jitterdodge",
"Nudge" = "nudge",
"Stack" = "stack"),
options = list(render = I(
"{
option: function(item, escape) {
return '<div class = \"position\"><span data-value = \"' + escape(item.value) + '\"></span>' + escape(item.label) + '</div>'
}
}")),
selected = init_position
),
switch(init_position %in% names(pos_to_sub),
checkboxInput(session$ns('position_sub'),
label = switch(pos_to_sub[[init_position]],
"fill" = "Normalize heights?",
"dodge2" = "Variable widths?"),
value = input[["position_sub"]] %||% (default_position %in% names(sub_to_pos))),
NULL)
)
})
})
# _ Make sure position chooser always update ====
outputOptions(output, "position_chooser", suspendWhenHidden = FALSE)
position_sub <- reactive({
req(input$position)
pos_to_sub[[ifelse(is.logical(input$position_sub) %||% NULL,
ifelse(input$position_sub,
input$position,
NA),
NA)]]
})
position <- reactive({
req(input$position)
position_sub() %||% input$position
})
additional_args <- reactive({
req(input$position)
pos_args <- formals(paste0("position_", input$position))
sub_args <- formals(paste0("position_", position_sub()))
sub_args[!(names(sub_args) %in% names(pos_args))]
})
output$position_options <- renderUI({
req(input$position, base_data())
refreshWidget$depend()
isolate({
if (isTruthy(base_data())) {
tagList(
# Main options
purrr::imap(formals(paste0("position_", input$position)), ~ {
tryCatch(
do.call(paste0(input$position, '_', .y, '_ui'),
list(value = .x, input = input, session = session, base_data = base_data)),
error = function(e) {
tryCatch(
do.call(paste0(.y,'_ui'),
list(value = .x, input = input, session = session, base_data = base_data)),
error = function(e) NULL
)
})
}
)
)
} else {
span("Please fix layer error before continuing.")
}
})
})
# _ Make sure position chooser always update ====
outputOptions(output, "position_options", suspendWhenHidden = FALSE)
output$position_sub_options <- renderUI({
req(position_sub())
# Sub options
isolate({
tagList(
purrr::imap(additional_args(), ~ {
tryCatch(
do.call(paste0(position_sub(), '_', .y, '_ui'),
list(value = .x, input = input, session = session, base_data = base_data)),
error = function(e) {
tryCatch(
do.call(paste0(.y,'_ui'),
list(value = .x, input = input, session = session, base_data = base_data)),
error = function(e) NULL
)
})
})
)
})
})
# _ Make sure position chooser always update ====
outputOptions(output, "position_sub_options", suspendWhenHidden = FALSE)
updateSelectizeInput(
session, 'position', server = TRUE,
choices = list("Identity" = "identity",
"Jitter" = "jitter",
"Dodge" = "dodge",
"Jitter-Dodge" = "jitterdodge",
"Nudge" = "nudge",
"Stack" = "stack")
)
position_code <- dedupe(reactive({
processed_position_code <- ''
if (isTruthy(input$position)) {
# Process arguments
args <- process_position_args(input$position, input, base_data)
subargs <- process_position_args(position_sub(), input, base_data)
args <- paste(c(switch(isTruthy(args), args), switch(isTruthy(subargs), subargs)), collapse = ", ")
if ((position() != default_position) || isTruthy(args)) {
processed_position_code <- paste0("position = position_", position(), "(")
processed_position_code <- paste0(processed_position_code, args)
processed_position_code <- paste0(processed_position_code, ")")
}
}
return(processed_position_code)
}))
return(position_code)
}
# Option inputs ----
# > reusable ui ----
reverse_ui <- function(position) {
id <- paste0(position, "_reverse")
function(value, input, session, base_data = NULL) {
if (is.null(value)) value = FALSE
checkboxInput(session$ns(id),
label = "Reverse?",
value = input[[id]] %||% value
)
}
}
width_ui <- function(position, type=NULL, default=0.4) {
id <- paste0(c(position, ifelse(is.null(type), "width", type)), collapse = "_")
function(value, input, session, base_data = NULL) {
if (is.null(value)) value = default
sliderInput(session$ns(id),
label = paste(c(switch(!is.null(type), .firstCap(type)), "Width:"), collapse = " "),
value = input[[id]] %||% value,
min = 0,
max = 1,
step = 0.05)
}
}
height_ui <- function(position, type=NULL, default=0.4) {
id <- paste0(c(position, ifelse(is.null(type), "height", type)), collapse = "_")
function(value, input, session, base_data = NULL) {
if (is.null(value)) value = default
sliderInput(session$ns(id),
label = paste(c(switch(!is.null(type), .firstCap(type)), "Height:"), collapse = " "),
value = input[[id]] %||% value,
min = 0,
max = 1,
step = 0.05)
}
}
seed_ui <- function(position) {
id <- paste0(position, "_seed")
function(value, input, session, base_data = NULL) {
if (!isTruthy(value)) value = sample.int(.Machine$integer.max, 1L)
div(
class = "seed-ui",
numericInput(session$ns(id),
label = 'Seed:',
value = input[[id]] %||% value,
min = 0,
max = .Machine$integer.max,
step = 1
),
actionButton(session$ns(paste0(id, '_refresh')),
label = '',
icon = icon('redo'))
)
}
}
# > jitter ----
jitter_width_ui <- width_ui("jitter")
jitter_height_ui <- height_ui("jitter")
jitter_seed_ui <- seed_ui("jitter")
jitter_server <- function(session, refreshWidget = NULL) {
return({
observeEvent(session$input[['jitter_seed_refresh']], {
updateNumericInput(session, 'jitter_seed', value = sample.int(.Machine$integer.max, 1L))
})
})
}
# > dodge ----
dodge_width_ui <- function(value, input, session, base_data = NULL) {
value <- input[["dodge_width"]] %||% value
div(
class = "position-dodge-width",
div(
class = "dodge-width-switch",
shinyWidgets::switchInput(
session$ns("dodge_set_width"),
label = "Width",
value = isTruthy(value)
)
),
div(
class = paste0("dodge-width-input", ifelse(isTruthy(value), "", " hidden")),
numericInput(session$ns("dodge_width"),
label = "",
value = value,
min = 0,
max = Inf
)
)
)
}
dodge_preserve_ui <- function(value, input, session, base_data = NULL) {
if (is.null(value) || (length(value) > 1)) value = "total"
radioButtons(session$ns("dodge_preserve"),
label = "Preserve:",
choices = c("total", "single"),
selected = input[["dodge_preserve"]] %||% value,
inline = TRUE)
}
dodge_server <- function(session, refreshWidget = NULL) {
return({
observeEvent(session$input$dodge_set_width, {
if (isTruthy(session$input$dodge_set_width)) {
shinyjs::js$toggleClass("hidden", paste0('#', session$ns("position_options"), ' .dodge-width-input'))
updateNumericInput(session, session$ns("dodge_width"), value = 0)
} else {
shinyjs::js$toggleClass("hidden", paste0('#', session$ns("position_options"), ' .dodge-width-input'))
session$sendCustomMessage(type = "nullify", message = session$ns("dodge_width"))
}
})
# Fire one event to refresh shinyWidget (current bug in shinyWidgets)
observeEvent(session$input$dodge_set_width, {
refreshWidget$trigger()
}, once = TRUE)
})
}
# > dodge2 ----
dodge2_padding_ui <- function(value, input, session, base_data = NULL) {
if (is.null(value)) value = 0.1
sliderInput(session$ns("dodge2_padding"),
label = "Padding:",
min = 0,
max = 1,
value = input[["dodge2_padding"]] %||% value,
step = 0.05)
}
dodge2_reverse_ui <- reverse_ui("dodge2")
# > stack/fill ----
stack_vjust_ui <- function(value, input, session, base_data = NULL) {
if (is.null(value)) value = 1
sliderInput(session$ns("stack_vjust"),
label = "Vertical adjustment:",
min = 0,
max = 1,
value = input[["stack_vjust"]] %||% value,
step = 0.05
)
}
stack_reverse_ui <- reverse_ui("stack")
# > nudge ----
nudge_x_ui <- function(value, input, session, base_data = NULL) {
if (is.null(value)) value = 0
sliderInput(session$ns("nudge_x"),
label = "Horizontal Adjustment:",
min = -1,
max = 1,
value = input[["nudge_x"]] %||% value,
step = 0.02)
}
nudge_y_ui <- function(value, input, session, base_data = NULL) {
if (is.null(value)) value = 0
sliderInput(session$ns("nudge_y"),
label = "Vertical Adjustment:",
min = -1,
max = 1,
value = input[["nudge_y"]] %||% value,
step = 0.02)
}
# > jitterdodge ----
jitterdodge_jitter.width_ui <- width_ui("jitterdodge", "jitter.width")
jitterdodge_jitter.height_ui <- height_ui("jitterdodge", "jitter.height", default = 0)
jitterdodge_seed_ui <- seed_ui("jitterdodge")
jitterdodge_dodge.width_ui <- width_ui("jitterdodge", "dodge.width", 0.75)
# Consider combining code with jitter_server
jitterdodge_server <- function(session, refreshWidget = NULL) {
return({
observeEvent(session$input[['jitterdodge_seed_refresh']], {
updateNumericInput(session, 'jitterdodge_seed', value = sample.int(.Machine$integer.max, 1L))
})
})
}
# Utils ----
# Get argument list for position function and set defaults
position_args <- function(position) {
pargs <- formals(paste0("position_", position))
if (!is.null(pargs)) {
names(pargs) <- paste0(position, "_", names(pargs))
pargs %>%
purrr::modify_at(c("jitter_width",
"jitterdodge_jitter.width",
"jitter_height"), ~ 0.4) %>%
purrr::modify_at(c("dodge_width", "dodge2_width"), ~ -1) %>%
purrr::modify_at(c("dodge_preserve", "dodge2_preserve"), ~ "total")
} else {
NULL
}
}
process_position_args <- function(position, input, base_data) {
if (is.null(position)) return(NULL)
purrr::imap(position_args(position), ~ filter_out_defaults(.y, .x, input[[.y]])) %>%
dropNulls() %>%
purrr::imap(~ modify_position_args(.y, .x, base_data)) %>%
purrr::imap(~ paste(stringr::str_split(.y, "_")[[1]][2], "=", .x)) %>%
paste(., collapse = ", ")
}
modify_position_args <- function(param, value, base_data) {
return(
switch(param,
"jitter_width" =,
"jitterdodge_jitter.width" = value*resolution(base_data()$x, zero = FALSE),
"jitter_height" =,
"jitterdodge_jitter.height" = value*resolution(base_data()$y, zero = FALSE),
"nudge_x" = value*(max(base_data()$x) - min(base_data()$x)),
"nudge_y" = value*(max(base_data()$y) - min(base_data()$y)),
value
)
)
}
.firstCap <- function(x) {
s <- strsplit(x, "[.]")[[1]][1]
paste0(toupper(substring(s, 1, 1)), substring(s, 2))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.