Skip to content

Instantly share code, notes, and snippets.

@trafficonese
Last active September 30, 2019 19:08
Show Gist options
  • Save trafficonese/04747d599f12a58052bb66bedc2f7eba to your computer and use it in GitHub Desktop.
Save trafficonese/04747d599f12a58052bb66bedc2f7eba to your computer and use it in GitHub Desktop.
pickerSelectOptions optimizations / benchmarks
## functions ##############
pickerSelectOptions <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) {
if (is.null(choicesOpt))
choicesOpt <- list()
l <- sapply(choices, length)
if (!is.null(maxOptGroup))
maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l))
m <- matrix(data = c(c(1, cumsum(l)[-length(l)] + 1), cumsum(l)), ncol = 2)
html <- lapply(seq_along(choices), FUN = function(i) {
label <- names(choices)[i]
choice <- choices[[i]]
if (is.list(choice)) {
optionTag <- list(
label = htmltools::htmlEscape(label, TRUE),
pickerSelectOptions(
choice, selected,
choicesOpt = lapply(
X = choicesOpt,
FUN = function(j) {
j[m[i, 1]:m[i, 2]]
}
)
)
)
if (!is.null(maxOptGroup))
optionTag[["data-max-options"]] <- maxOptGroup[i]
optionTag <- dropNulls(optionTag)
do.call(htmltools::tags$optgroup, optionTag)
} else {
optionTag <- list(
value = choice, htmltools::HTML(htmltools::htmlEscape(label)),
style = choicesOpt$style[i],
`data-icon` = choicesOpt$icon[i],
`data-subtext` = choicesOpt$subtext[i],
`data-content` = choicesOpt$content[i],
disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled",
selected = if (choice %in% selected) "selected" else NULL
)
# optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else ""))
optionTag <- dropNulls(optionTag)
do.call(htmltools::tags$option, optionTag)
}
})
return(htmltools::tagList(html))
}
pickerSelectOptions1 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) {
if (is.null(choicesOpt))
choicesOpt <- list()
l <- sapply(choices, length)
if (!is.null(maxOptGroup))
maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l))
m <- matrix(data = c(c(1, cumsum(l)[-length(l)] + 1), cumsum(l)), ncol = 2)
namechoice <- names(choices)
html <- lapply(1:length(choices), FUN = function(i) {
label <- namechoice[i]
choice <- choices[[i]]
if (is.list(choice)) {
optionTag <- list(
label = htmlEscape(label, TRUE),
pickerSelectOptions1(
choice, selected,
choicesOpt = lapply(
X = choicesOpt,
FUN = function(j) {
j[m[i, 1]:m[i, 2]]
}
)
)
)
if (!is.null(maxOptGroup))
optionTag[["data-max-options"]] <- maxOptGroup[i]
optionTag <- dropNulls(optionTag)
do.call(tags$optgroup, optionTag)
} else {
optionTag <- list(
value = choice, HTML(htmlEscape(label)),
style = choicesOpt$style[i],
`data-icon` = choicesOpt$icon[i],
`data-subtext` = choicesOpt$subtext[i],
`data-content` = choicesOpt$content[i],
disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled",
selected = if (choice %in% selected) "selected" else NULL
)
# optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else ""))
optionTag <- dropNulls(optionTag)
do.call(tags$option, optionTag)
}
})
return(tagList(html))
}
pickerSelectOptions2 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) {
if (is.null(choicesOpt))
choicesOpt <- list()
l <- sapply(choices, length)
if (!is.null(maxOptGroup))
maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l))
cs <- cumsum(l)
m <- matrix(data = c(c(1, cs[-length(l)] + 1), cs), ncol = 2)
namechoice <- names(choices)
html <- lapply(1:length(choices), FUN = function(i) {
label <- namechoice[i]
choice <- choices[[i]]
if (is.list(choice)) {
optionTag <- list(
label = htmlEscape(label, TRUE),
pickerSelectOptions2(
choice, selected,
choicesOpt = lapply(
X = choicesOpt,
FUN = function(j) {
j[m[i, 1]:m[i, 2]]
}
)
)
)
if (!is.null(maxOptGroup))
optionTag[["data-max-options"]] <- maxOptGroup[i]
optionTag <- dropNulls(optionTag)
do.call(tags$optgroup, optionTag)
} else {
optionTag <- list(
value = choice, HTML(htmlEscape(label)),
style = choicesOpt$style[i],
`data-icon` = choicesOpt$icon[i],
`data-subtext` = choicesOpt$subtext[i],
`data-content` = choicesOpt$content[i],
disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled",
selected = if (choice %in% selected) "selected" else NULL
)
# optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else ""))
optionTag <- dropNulls(optionTag)
do.call(tags$option, optionTag)
}
})
return(tagList(html))
}
pickerSelectOptions3 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) {
if (is.null(choicesOpt)) choicesOpt <- list()
l <- sapply(choices, length)
if (!is.null(maxOptGroup)) maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l))
cs <- cumsum(l)
m <- matrix(data = c(c(1, cs[-length(l)] + 1), cs), ncol = 2)
namechoice <- names(choices)
tagList(lapply(1:length(choices), function(i) {
label <- namechoice[i]
choice <- choices[[i]]
if (is.list(choice)) {
optionTag <- list(
label = htmlEscape(label, TRUE),
pickerSelectOptions3(
choice, selected,
choicesOpt = lapply(
X = choicesOpt,
FUN = function(j) {
j[m[i, 1]:m[i, 2]]
}
)
)
)
if (!is.null(maxOptGroup))
optionTag[["data-max-options"]] <- maxOptGroup[i]
optionTag <- dropNulls(optionTag)
do.call(tags$optgroup, optionTag)
} else {
if (length(choicesOpt) == 0) {
optionTag <- list(
value = choice, HTML(htmlEscape(label)),
selected = if (any(choice == selected)) "selected" else NULL
)
} else {
optionTag <- list(
value = choice, HTML(htmlEscape(label)),
style = choicesOpt$style[i],
`data-icon` = choicesOpt$icon[i],
`data-subtext` = choicesOpt$subtext[i],
`data-content` = choicesOpt$content[i],
disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled",
selected = if (any(choice == selected)) "selected" else NULL
)
}
# optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else ""))
optionTag <- dropNulls(optionTag)
do.call(tags$option, optionTag)
}
}))
}
dropNulls1 <- function(x) {
x[lengths(x) != 0]
}
pickerSelectOptions4 <- function(choices, selected = NULL, choicesOpt = NULL, maxOptGroup = NULL) {
if (is.null(choicesOpt)) choicesOpt <- list()
l <- sapply(choices, length)
if (!is.null(maxOptGroup)) maxOptGroup <- rep_len(x = maxOptGroup, length.out = sum(l))
cs <- cumsum(l)
m <- matrix(data = c(1, cs[-length(l)] + 1, cs), ncol = 2)
namechoice <- names(choices)
tagList(lapply(1:length(choices), function(i) {
label <- namechoice[i]
choice <- choices[[i]]
if (is.list(choice)) {
optionTag <- list(
label = htmlEscape(label, TRUE),
pickerSelectOptions4(
choice, selected,
choicesOpt = lapply(
X = choicesOpt,
FUN = function(j) {
j[m[i, 1]:m[i, 2]]
}
)
)
)
if (!is.null(maxOptGroup))
optionTag[["data-max-options"]] <- maxOptGroup[i]
optionTag <- dropNulls1(optionTag)
do.call(tags$optgroup, optionTag)
} else {
if (length(choicesOpt) == 0) {
optionTag <- list(
value = choice, if (is.null(label)) HTML(NULL) else HTML(htmlEscape(label)),
selected = if (any(choice == selected)) "selected" else NULL
)
} else {
optionTag <- list(
value = choice, if (is.null(label)) HTML(NULL) else HTML(htmlEscape(label)),
style = choicesOpt$style[i],
`data-icon` = choicesOpt$icon[i],
`data-subtext` = choicesOpt$subtext[i],
`data-content` = choicesOpt$content[i],
disabled = if (!is.null(choicesOpt$disabled[i]) && choicesOpt$disabled[i]) "disabled",
selected = if (any(choice == selected)) "selected" else NULL
)
}
# optionTag$attribs <- c(optionTag$attribs, list(if (choice %in% selected) " selected" else ""))
optionTag <- dropNulls1(optionTag)
do.call(tags$option, optionTag)
}
}))
}
## benchmarks ################
choices <- sample.int(1e6, 1e4)
mc <- microbenchmark::microbenchmark(times = 20,
res0 = shinyWidgets:::pickerSelectOptions(choices, choices[100] , NULL, NULL),
res1 = shinyWidgets:::pickerSelectOptions1(choices, choices[100] , NULL, NULL),
res2 = shinyWidgets:::pickerSelectOptions2(choices, choices[100] , NULL, NULL),
res3 = shinyWidgets:::pickerSelectOptions3(choices, choices[100] , NULL, NULL),
res4 = shinyWidgets:::pickerSelectOptions4(choices, choices[100] , NULL, NULL)
); mc
## identical ####################
res0 = shinyWidgets:::pickerSelectOptions(choices, choices[100], NULL, NULL)
res1 = shinyWidgets:::pickerSelectOptions1(choices, choices[100], NULL, NULL)
res2 = shinyWidgets:::pickerSelectOptions2(choices, choices[100], NULL, NULL)
res3 = shinyWidgets:::pickerSelectOptions3(choices, choices[100], NULL, NULL)
res4 = shinyWidgets:::pickerSelectOptions4(choices, choices[100], NULL, NULL)
identical(res0, res1); identical(res0, res2); identical(res0, res3); identical(res0, res4)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment