#' Framework7 autocomplete input
#'
#' \code{f7AutoComplete} generates a Framework7 autocomplete input.
#'
#' @param inputId Autocomplete input id.
#' @param label Autocomplete label.
#' @param placeholder Text to write in the container.
#' @param value Autocomplete initial value, if any.
#' @param choices Autocomplete choices.
#' @param openIn Defines how to open Autocomplete,
#' can be page or popup (for Standalone) or dropdown.
#' @param typeahead Enables type ahead, will prefill input
#' value with first item in match. Only if openIn is "dropdown".
#' @param expandInput `r lifecycle::badge("deprecated")`:
#' removed from Framework7.
#' @param closeOnSelect Set to true and autocomplete will be closed when user picks value.
#' Not available if multiple is enabled. Only works
#' when openIn is 'popup' or 'page'.
#' @param dropdownPlaceholderText Specify dropdown placeholder text.
#' Only if openIn is "dropdown".
#' @param multiple Whether to allow multiple value selection. Only works
#' when openIn is 'popup' or 'page'.
#' @param limit Limit number of maximum displayed items in autocomplete per query.
#' @param ... Extra options.
#' See \url{https://framework7.io/docs/autocomplete#autocomplete-parameters}
#' @param style Autocomplete styling parameters.
#' Only available when `openIn` is "dropdown".
#'
#' @rdname autocomplete
#' @note Contrary to \link{f7Text}, this input can't be cleared.
#'
#' @example inst/examples/autocomplete/app.R
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
f7AutoComplete <- function(
inputId, label = NULL, placeholder = NULL,
value = NULL, choices,
openIn = c("popup", "page", "dropdown"),
typeahead = TRUE, expandInput = deprecated(), closeOnSelect = FALSE,
dropdownPlaceholderText = NULL, multiple = FALSE, limit = NULL,
style = list(
media = NULL,
description = NULL,
floating = FALSE,
outline = FALSE
), ...) {
if (lifecycle::is_present(expandInput)) {
lifecycle::deprecate_warn(
when = "2.0.0",
what = "f7AutoComplete(expandInput)",
details = "expandInput has been
removed from Framework7 and will be removed from shinyMobile
in the next release."
)
}
type <- match.arg(openIn)
if (is.null(value)) value <- character()
is_standalone <- type %in% c("page", "popup")
config <- dropNulls(
list(
choices = choices,
value = I(value),
openIn = type,
limit = limit,
multiple = if (is_standalone) multiple,
closeOnSelect = if (is_standalone) closeOnSelect,
typeahead = if (!is_standalone) typeahead,
dropdownPlaceholderText = if (!is_standalone) dropdownPlaceholderText,
...
)
)
configTag <- buildConfig(inputId, config)
# wrap props
autoCompleteInnerTag <- if (!is_standalone) {
shiny::tags$input(
id = inputId,
class = "autocomplete-input",
type = "text",
placeholder = placeholder,
configTag
)
} else {
tempTag <- shiny::tags$a(
id = inputId,
class = "autocomplete-input item-link item-content",
href = "#",
configTag
)
shiny::tagAppendChildren(
tempTag,
shiny::tags$input(type = "hidden"),
shiny::tags$div(
class = "item-inner",
# label
shiny::tags$div(class = "item-title", label),
# input
shiny::tags$div(class = "item-after")
)
)
}
# input tag + label wrapper
style$clearable <- FALSE
if (!is_standalone) {
listify(
htmltools::tagQuery(
createInputLayout(
label = label,
autoCompleteInnerTag,
style = style
)
)$
find(".item-input")$
addClass("inline-label")$
allTags()
)
} else {
listify(autoCompleteInnerTag)
}
}
#' Update Framework7 autocomplete
#'
#' \code{updateF7AutoComplete} changes the value of an autocomplete input on the client.
#'
#' @param session The Shiny session object.
#'
#' @export
#' @rdname autocomplete
updateF7AutoComplete <- function(inputId, value = NULL, choices = NULL, ...,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(
list(
value = I(value),
choices = choices,
...
)
)
session$sendInputMessage(inputId, message)
}
#' Framework7 picker input
#'
#' \code{f7Picker} generates a picker input.
#'
#' @param inputId Picker input id.
#' @param label Picker label.
#' @param placeholder Text to write in the container.
#' @param value Picker initial value, if any.
#' @param choices Picker choices.
#' @param rotateEffect Enables 3D rotate effect. Default to TRUE.
#' @param openIn Can be auto, popover (to open picker in popover), sheet (to open in sheet modal).
#' In case of auto will open in sheet modal on small screens and in popover on large screens. Default
#' to auto.
#' @param scrollToInput Scroll viewport (page-content) to input when picker opened. Default
#' to FALSE.
#' @param closeByOutsideClick If enabled, picker will be closed by clicking outside of picker or related input element.
#' Default to TRUE.
#' @param toolbar Enables picker toolbar. Default to TRUE.
#' @param toolbarCloseText Text for Done/Close toolbar button.
#' @param sheetSwipeToClose Enables ability to close Picker sheet with swipe. Default to FALSE.
#' @param style Input style. Inherit from \link{f7List} options
#' such as outline, inset, strong and dividers.
#' @param ... Other options to pass to the picker. See
#' \url{https://framework7.io/docs/picker#picker-parameters}.
#'
#' @rdname picker
#' @example inst/examples/picker/app.R
#' @author David Granjon, \email{dgranjon@@ymail.com}
#'
#' @export
f7Picker <- function(inputId, label, placeholder = NULL, value = choices[1], choices,
rotateEffect = TRUE, openIn = "auto", scrollToInput = FALSE,
closeByOutsideClick = TRUE, toolbar = TRUE, toolbarCloseText = "Done",
sheetSwipeToClose = FALSE, style = list(
inset = FALSE,
outline = FALSE,
strong = FALSE,
dividers = FALSE
), ...) {
if (length(value) > 1) stop("value must be a single element")
# JS needs array
if (!is.null(value)) {
value <- list(value)
} else {
value <- list()
}
# TO DO: create helper function for sheet, picker, ...
# since they're all the same ...
config <- dropNulls(
list(
value = value,
values = choices,
displayValues = if (length(names(choices))) names(choices),
rotateEffect = rotateEffect,
openIn = openIn,
scrollToInput = scrollToInput,
closeByOutsideClick = closeByOutsideClick,
toolbar = toolbar,
toolbarCloseText = toolbarCloseText,
sheetSwipeToClose = sheetSwipeToClose,
...
)
)
buildPickerInput(
inputId,
label,
config,
"picker-input",
placeholder,
style
)
}
#' Build input tag for picker elements
#'
#' @keywords internal
buildPickerInput <- function(id, label, config, class, placeholder = NULL, style = NULL) {
pickerInnerTag <-
shiny::tags$div(
class = "item-input-wrap",
shiny::tags$input(
id = id,
class = class,
type = "text",
placeholder = placeholder
),
buildConfig(id, config)
)
# if not wrapped inside f7List, return "standalone" picker
if (!is_wrapped()) {
tagList(
shiny::tags$div(
class = "block-title",
label
),
listify(
tagList(
htmltools::tagQuery(f7ListItem())$
find(".item-inner")$
append(pickerInnerTag)$
allTags()
),
style
)
)
} else {
item <-
listify(
htmltools::tagQuery(
f7ListItem(title = label)
)$
find(".item-inner")$
append(pickerInnerTag)$
allTags(),
style
)
item <-
htmltools::tagQuery(item)$
find(".item-title")$
addClass("item-label")$
allTags()
htmltools::tagQuery(item)$
find(".item-content")$
addClass("item-input")$
allTags()
}
}
#' Build config tag for JavaScript
#'
#' See \url{https://unleash-shiny.rinterface.com/shiny-input-system#boxes-on-steroids-more}
#'
#' @keywords internal
buildConfig <- function(id, config) {
shiny::tags$script(
type = "application/json",
`data-for` = id,
jsonlite::toJSON(
x = config,
auto_unbox = TRUE,
json_verbatim = TRUE
)
)
}
#' Update Framework7 picker
#'
#' \code{updateF7Picker} changes the value of a picker input on the client.
#'
#' @param session The Shiny session object, usually the default value will suffice.
#'
#' @export
#' @rdname picker
updateF7Picker <- function(inputId, value = NULL, choices = NULL,
rotateEffect = NULL, openIn = NULL, scrollToInput = NULL,
closeByOutsideClick = NULL, toolbar = NULL, toolbarCloseText = NULL,
sheetSwipeToClose = NULL, ...,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(
list(
value = value,
choices = choices,
rotateEffect = rotateEffect,
openIn = openIn,
scrollToInput = scrollToInput,
closeByOutsideClick = closeByOutsideClick,
toolbar = toolbar,
toolbarCloseText = toolbarCloseText,
sheetSwipeToClose = sheetSwipeToClose,
...
)
)
session$sendInputMessage(inputId, message)
}
f7ColorPickerPalettes <- list(
c(
"#FFEBEE", "#FFCDD2", "#EF9A9A",
"#E57373", "#EF5350", "#F44336",
"#E53935", "#D32F2F", "#C62828",
"#B71C1C"
),
c(
"#F3E5F5", "#E1BEE7", "#CE93D8",
"#BA68C8", "#AB47BC", "#9C27B0",
"#8E24AA", "#7B1FA2", "#6A1B9A",
"#4A148C"
),
c(
"#E8EAF6", "#C5CAE9", "#9FA8DA",
"#7986CB", "#5C6BC0", "#3F51B5",
"#3949AB", "#303F9F", "#283593",
"#1A237E"
),
c(
"#E1F5FE", "#B3E5FC", "#81D4FA",
"#4FC3F7", "#29B6F6", "#03A9F4",
"#039BE5", "#0288D1", "#0277BD",
"#01579B"
),
c(
"#E0F2F1", "#B2DFDB", "#80CBC4",
"#4DB6AC", "#26A69A", "#009688",
"#00897B", "#00796B", "#00695C",
"#004D40"
),
c(
"#F1F8E9", "#DCEDC8", "#C5E1A5",
"#AED581", "#9CCC65", "#8BC34A",
"#7CB342", "#689F38", "#558B2F",
"#33691E"
),
c(
"#FFFDE7", "#FFF9C4", "#FFF59D",
"#FFF176", "#FFEE58", "#FFEB3B",
"#FDD835", "#FBC02D", "#F9A825",
"#F57F17"
),
c(
"#FFF3E0", "#FFE0B2", "#FFCC80",
"#FFB74D", "#FFA726", "#FF9800",
"#FB8C00", "#F57C00", "#EF6C00",
"#E65100"
)
)
f7ColorPickerModules <- c(
"wheel", "sb-spectrum",
"hue-slider", "hs-spectrum",
"brightness-slider", "rgb-slider",
"hsb-sliders", "alpha-slider",
"rgb-bars", "palette", "hex",
"current-color", "initial-current-colors"
)
globalVariables(c("f7ColorPickerPalettes", "f7ColorPickerModules"))
#' Create a Framework7 color picker input
#'
#' @param inputId Color picker input.
#' @param label Color picker label.
#' @param value Initial picker value in hex.
#' @param placeholder Color picker placeholder.
#' @param modules Picker color modules. Choose at least one.
#' @param palettes Picker color predefined palettes. Must be a list
#' of color vectors, each value specified as HEX string.
#' @param sliderValue When enabled, it will display sliders values.
#' @param sliderValueEditable When enabled, it will display sliders values as <input>
#' elements to edit directly.
#' @param sliderLabel When enabled, it will display sliders labels with text.
#' @param hexLabel When enabled, it will display HEX module label text, e.g. HEX.
#' @param hexValueEditable When enabled, it will display HEX module value as <input> element to edit directly.
#' @param groupedModules When enabled it will add more exposure
#' to sliders modules to make them look more separated.
#' @param style Input style. Inherit from \link{f7List} options
#' such as outline, inset, strong and dividers.
#' @param ... Other options to pass to the picker. See
#' \url{https://framework7.io/docs/color-picker#color-picker-parameters}.
#'
#' @return The return value is a list and includes hex, rgb, hsl, hsb, alpha, hue, rgba, and hsla values.
#' See \url{https://framework7.io/docs/color-picker#color-picker-value}.
#'
#' @example inst/examples/colorpicker/app.R
#'
#' @export
f7ColorPicker <- function(inputId, label, value = "#ff0000", placeholder = NULL,
modules = f7ColorPickerModules, palettes = f7ColorPickerPalettes,
sliderValue = TRUE, sliderValueEditable = TRUE,
sliderLabel = TRUE, hexLabel = TRUE,
hexValueEditable = TRUE, groupedModules = TRUE,
style = list(
outline = FALSE,
inset = FALSE,
strong = FALSE,
dividers = FALSE
), ...) {
if (!is.null(value) && length(value) == 1) {
# needed by JS (array)
value <- list(hex = value)
} else {
stop("value cannot be NULL and must be a single color")
}
config <- dropNulls(list(
value = value,
modules = modules,
palettes = palettes,
sliderValue = sliderValue,
sliderValueEditable = sliderValueEditable,
sliderLabel = sliderLabel,
hexLabel = hexLabel,
hexValueEditable = hexValueEditable,
groupedModules = groupedModules,
...
))
buildPickerInput(
inputId,
label,
config,
"color-picker-input",
placeholder,
style
)
}
#' Framework7 date picker
#'
#' \code{f7DatePicker} creates a Framework7 date picker input.
#'
#' @param inputId Date input id.
#' @param label Input label.
#' @param value Array with initial selected dates. Each array item represents selected date.
#' If timePicker enabled, the value needs to be an object of type POSIXct.
#' @param multiple If \code{TRUE} allow to select multiple dates.
#' @param direction Months layout direction, could be 'horizontal' or 'vertical'.
#' @param minDate Minimum allowed date.
#' @param maxDate Maximum allowed date.
#' @param dateFormat Date format: "yyyy-mm-dd", for instance.
#' @param openIn Can be auto, popover (to open calendar in popover), sheet
#' (to open in sheet modal) or customModal (to open in custom Calendar modal overlay).
#' In case of auto will open in sheet modal on small screens and in popover on large screens.
#' @param scrollToInput Scroll viewport (page-content) to input when calendar opened.
#' @param closeByOutsideClick If enabled, picker will be closed by clicking outside of picker or related input element.
#' @param toolbar Enables calendar toolbar.
#' @param toolbarCloseText Text for Done/Close toolbar button.
#' @param header Enables calendar header.
#' @param headerPlaceholder Default calendar header placeholder text.
#' @param style Input style. Inherit from \link{f7List} options
#' such as outline, inset, strong and dividers.
#' @param ... Other options to pass to the picker. See
#' \url{https://framework7.io/docs/calendar#calendar-parameters}.
#'
#' @importFrom jsonlite toJSON
#' @rdname datepicker
#'
#' @return a \code{Date} vector.
#'
#' @export
#' @example inst/examples/datepicker/app.R
f7DatePicker <- function(inputId, label, value = NULL, multiple = FALSE, direction = c("horizontal", "vertical"),
minDate = NULL, maxDate = NULL, dateFormat = "yyyy-mm-dd",
openIn = c("auto", "popover", "sheet", "customModal"),
scrollToInput = FALSE, closeByOutsideClick = TRUE,
toolbar = TRUE, toolbarCloseText = "Done", header = FALSE,
headerPlaceholder = "Select date",
style = list(
outline = FALSE,
inset = FALSE,
strong = FALSE,
dividers = FALSE
), ...) {
direction <- match.arg(direction)
openIn <- match.arg(openIn)
if (!is.null(value) && length(value) == 1) {
value <- list(value)
}
config <- dropNulls(list(
value = value,
multiple = multiple,
direction = direction,
minDate = minDate,
maxDate = maxDate,
dateFormat = dateFormat,
openIn = openIn,
scrollToInput = scrollToInput,
closeByClickOutside = closeByOutsideClick,
toolbar = toolbar,
toolbarCloseText = toolbarCloseText,
header = header,
headerPlaceholder = headerPlaceholder,
...
))
buildPickerInput(
inputId,
label,
config,
"calendar-input",
style = style
)
}
#' Update Framework7 date picker
#'
#' \code{updateF7DatePicker} changes the value of a date picker input on the client.
#'
#' @param session The Shiny session object, usually the default value will suffice.
#'
#' @export
#'
#' @rdname datepicker
updateF7DatePicker <- function(inputId, value = NULL, ...,
session = shiny::getDefaultReactiveDomain()) {
if (!is.null(value)) {
if (length(value) == 1) {
value <- list(as.character(value))
} else {
value <- as.character(value)
}
}
config <- dropNulls(list(...))
if (length(config) == 0) {
config <- NULL
}
message <- dropNulls(list(
value = value,
config = config
))
session$sendInputMessage(inputId, message)
}
#' Framework7 checkbox
#'
#' \link{f7Checkbox} creates a checkbox input.
#'
#' @param inputId The input slot that will be used to access the value.
#' @param label Display label for the control, or NULL for no label.
#' @param value Initial value (TRUE or FALSE).
#'
#' @rdname checkbox
#' @example inst/examples/checkbox/app.R
#' @export
f7Checkbox <- function(inputId, label, value = FALSE) {
value <- shiny::restoreInput(id = inputId, default = value)
inputTag <- shiny::tags$input(id = inputId, type = "checkbox")
if (!is.null(value) && value) {
inputTag$attribs$checked <- "checked"
}
shiny::tagList(
shiny::tags$span(label),
shiny::tags$label(
class = "checkbox",
inputTag,
shiny::tags$i(class = "icon-checkbox"),
)
)
}
#' Update Framework7 checkbox
#'
#' \code{updateF7Checkbox} changes the value of a checkbox input on the client.
#'
#' @rdname checkbox
#' @param session The Shiny session object.
#' @export
updateF7Checkbox <- function(inputId, label = NULL, value = NULL,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(label = label, value = value))
session$sendInputMessage(inputId, message)
}
#' Framework7 checkbox group
#'
#' \code{f7CheckboxGroup} creates a checkbox group input
#'
#' @inheritParams f7GroupInput
#'
#' @export
#' @rdname checkboxgroup
#'
#' @example inst/examples/checkboxgroup/app.R
f7CheckboxGroup <- function(
inputId, label, choices = NULL, selected = NULL,
position = c("left", "right"), style = list(
inset = FALSE,
outline = FALSE, dividers = FALSE, strong = FALSE
)) {
position <- match.arg(position)
f7GroupInput(
type = "checkbox",
inputId = inputId,
label = label,
choices = choices,
selected = selected,
position = position,
style = style
)
}
#' Framework7 checkbox group custom choice
#'
#' Custom choice item for \link{f7CheckboxGroup}.
#'
#' @param ... Choice content. Text is striped if too long.
#' @param title Item title.
#' @param subtitle Item subtitle.
#' @param after Display at the right of title.
#'
#' @export
#' @rdname checkboxgroup
f7CheckboxChoice <- function(..., title, subtitle = NULL, after = NULL) {
# We can benefit from f7ListItem, though we don't
# need all of the generated tag, hence the use of
# htmltools::tagQuery ...
structure(
htmltools::tagQuery(
f7ListItem(
...,
media = f7Icon(), # fake item to force layout
title = title,
subtitle = subtitle,
right = after,
mode = "media"
)
)$
find(".item-inner")$
selectedTags()[[1]]$
children,
class = "custom_choice"
)
}
#' Create option html tag based on choice input
#'
#' Used by \link{f7SmartSelect} and \link{f7Select}
#'
#' @param choices Vector of possibilities.
#' @param selected Default selected value.
#' @keywords internal
createSelectOptions <- function(choices, selected) {
choices <- choicesWithNames(choices)
lapply(X = seq_along(choices), function(i) {
if (inherits(choices[[1]], "list")) {
shiny::tags$optgroup(
label = names(choices)[i],
lapply(X = seq_along(choices[[i]]), function(j) {
shiny::tags$option(
value = choices[[i]][[j]],
names(choices[[i]])[j],
selected = if (!is.null(selected)) {
if (choices[[i]][[j]] %in% selected) NA else NULL
}
)
})
)
} else {
shiny::tags$option(
value = choices[[i]],
names(choices)[i],
selected = if (!is.null(selected)) {
if (choices[[i]] %in% selected) NA else NULL
}
)
}
})
}
choicesWithNames <- function(choices) {
listify <- function(obj) {
makeNamed <- function(x) {
if (is.null(names(x))) {
names(x) <- character(length(x))
}
x
}
res <- lapply(obj, function(val) {
if (is.list(val)) {
listify(val)
} else if (length(val) == 1 && is.null(names(val))) {
val
} else {
makeNamed(as.list(val))
}
})
makeNamed(res)
}
choices <- listify(choices)
if (length(choices) == 0) {
return(choices)
}
choices <- mapply(choices, names(choices), FUN = function(choice,
name) {
if (!is.list(choice)) {
return(choice)
}
if (name == "") {
stop("All sub-lists in \"choices\" must be named.")
}
choicesWithNames(choice)
}, SIMPLIFY = FALSE)
missing <- names(choices) == ""
names(choices)[missing] <- as.character(choices)[missing]
choices
}
#' Framework7 select input
#'
#' \code{f7Select} creates a select input.
#'
#' @param choices Select input choices.
#' @param selected Select input default selected value.
#' @param width The width of the input, e.g. \code{400px}, or \code{100\%}.
#' @inheritParams f7Text
#'
#' @note Contrary to \link{f7Text}, \link{f7Select} can't be cleared and
#' label can't float.
#'
#' @export
#' @rdname select
#'
#' @example inst/examples/select/app.R
f7Select <- function(
inputId, label, choices, selected = NULL, width = NULL,
style = list(
media = NULL,
description = NULL,
outline = FALSE
)) {
options <- createSelectOptions(choices, selected)
style$clearable <- FALSE # Can't be cleared
style$floating <- FALSE # Can't be changed because can't be cleared
selectTag <- createInputLayout(
shiny::tags$select(
class = "input-select",
id = inputId,
placeholder = "Please choose...",
options
),
label = label,
dropdown = TRUE,
style = style
)
if (!is.null(width)) {
selectTag$attribs$style <- paste0("width:", htmltools::validateCssUnit(width), ";")
}
selectTag
}
#' Update Framework7 select
#'
#' \code{updateF7Select} changes the value of a select input on the client
#'
#' @param session The Shiny session object, usually the default value will suffice.
#'
#' @export
#' @rdname select
updateF7Select <- function(inputId, selected = NULL,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(
selected = selected
))
session$sendInputMessage(inputId, message)
}
#' Framework7 smart select
#'
#' \code{f7SmartSelect} is smarter than the classic \link{f7Select},
#' allows for choices filtering, ...
#'
#' @param inputId Select input id.
#' @param label Select input label.
#' @param choices Select input choices.
#' @param selected Default selected item. If NULL, the first item is selected.
#' @param openIn Smart select type: either \code{c("sheet", "popup", "popover")}.
#' Note that the search bar is only available when the type is popup.
#' @param searchbar Whether to enable the search bar. TRUE by default.
#' @param multiple Whether to allow multiple values. FALSE by default.
#' @param maxLength Maximum items to select when multiple is TRUE.
#' @param virtualList Enable Virtual List for smart select if your select has a lot
#' of options. Default to FALSE.
#' @param ... Other options. See \url{https://framework7.io/docs/smart-select#smart-select-parameters}.
#'
#' @rdname smartselect
#'
#' @export
#'
#' @example inst/examples/smartselect/app.R
f7SmartSelect <- function(inputId, label, choices, selected = NULL,
openIn = c("page", "sheet", "popup", "popover"),
searchbar = TRUE, multiple = FALSE, maxLength = NULL,
virtualList = FALSE, ...) {
options <- createSelectOptions(choices, selected)
type <- match.arg(openIn)
config <- dropNulls(list(
openIn = type,
searchbar = searchbar,
searchbarPlaceholder = "Search",
virtualList = virtualList,
maxLength = maxLength,
...
))
listify(
shiny::tags$li(
shiny::tags$a(
class = "item-link smart-select",
id = inputId,
shiny::tags$select(
multiple = if (multiple) NA else NULL,
options
),
htmltools::tagQuery(
f7ListItem(title = label)
)$
find(".item-content")$
selectedTags(),
buildConfig(inputId, config)
)
)
)
}
#' Update Framework7 smart select
#'
#' \code{updateF7SmartSelect} changes the value of a smart select input on the client.
#'
#' @param session The Shiny session object, usually the default value will suffice.
#'
#' @rdname smartselect
#' @export
updateF7SmartSelect <- function(inputId, selected = NULL, choices = NULL, multiple = NULL,
maxLength = NULL, ...,
session = shiny::getDefaultReactiveDomain()) {
if (!is.null(selected)) {
if (length(selected) == 1) {
selected <- list(as.character(selected))
} else {
selected <- as.character(selected)
}
}
config <- dropNulls(list(...))
if (length(config) == 0) {
config <- NULL
}
message <- dropNulls(list(
selected = selected,
choices = choices,
multiple = multiple,
maxLength = maxLength,
config = config
))
session$sendInputMessage(inputId, message)
}
#' Input layout default options
#'
#' @keywords internal
inputLayoutDefaults <- function() {
list(
media = NULL,
description = NULL,
floating = FALSE,
outline = FALSE,
clearable = TRUE
)
}
#' Create common input layout
#'
#' See \url{https://framework7.io/docs/inputs#inputs-layout}.
#'
#' @importFrom utils modifyList
#'
#' @keywords internal
createInputLayout <- function(
..., label = NULL, style, dropdown = FALSE) {
# make sure style does contain all defaults
# this prevents an error when the users only provides
# a subset of the style options
style <- modifyList(inputLayoutDefaults(), style)
if (style$floating && is.null(label)) {
stop("floating can't be used when label is NULL")
}
item <- f7ListItem(
media = style$media, # icon
title = label # label
)
classes <- c(
"item-input",
if (style$outline) "item-input-outline",
if (!is.null(style$description)) "item-input-with-info"
)
item <- htmltools::tagQuery(item)$
find(".item-content")$
addClass(classes)$
allTags()
# Add label on title + add input wrap sibling
if (!is.null(label)) {
item <- htmltools::tagQuery(item)$
find(".item-title")$
addClass("item-label")$
allTags()
}
innerItems <- shiny::tags$div(
class = paste0(
"item-input-wrap",
if (dropdown) " input-dropdown-wrap"
),
...,
if (style$clearable) shiny::span(class = "input-clear-button"),
if (!is.null(style$description)) {
shiny::tags$div(
class = "item-input-info",
style$description
)
}
)
item <- if (is.null(label)) {
htmltools::tagQuery(item)$
find(".item-inner")$
append(innerItems)$
allTags()
} else {
htmltools::tagQuery(item)$
find(".item-title")$
after(innerItems)$
allTags()
}
if (style$floating) {
item <- htmltools::tagQuery(item)$
find(".item-title")$
removeClass("item-label")$
addClass("item-floating-label")$
allTags()
}
# Is item wrapped in a f7List? If yes, we return it,
# if no, we wrap it to avoid rendering issues.
# This list can't be styled as this would conflict
# with the input style.
listify(item)
}
#' Check if f7List is in call stack
#' @keywords internal
is_wrapped <- function() {
sum(
grepl(
"^f7List",
perl = TRUE,
as.character(sys.calls())
)
) == 1
}
#' Listify a tag
#' @keywords internal
listify <- function(tag, style = NULL) {
# This list can only be styled by inputs making use
# of the buildPicker function. For others, it would
# conflict with the input style.
if (!is.null(style) & !is_wrapped()) {
do.call(f7List, c(tag, style))
} else if (!is_wrapped()) {
f7List(tag)
} else {
tag
}
}
#' Create an input tag
#'
#' Useful for text inputs, password input ...
#'
#' @keywords internal
createInputTag <- function(inputId, value = NULL, type, placeholder, ...) {
tagFunc <- if (type %in% c("textarea", "select")) {
shiny::tags[[type]]
} else {
shiny::tags$input
}
tagFunc(
id = inputId,
value = value,
if (type == "textarea") value,
type = type,
placeholder = placeholder,
...
)
}
#' Framework7 text input
#'
#' \code{f7Text} creates a text input container.
#'
#' @param inputId Text input id.
#' @param label Text input label.
#' @param value Text input value.
#' @param placeholder Text input placeholder.
#' @param style Input style. A list with media (image or icon),
#' description (text), floating, outline and clearable (booleans).
#'
#' @rdname text
#'
#' @export
#'
#' @example inst/examples/text/app.R
f7Text <- function(
inputId, label = NULL, value = "", placeholder = NULL,
style = list(
media = NULL,
description = NULL,
floating = FALSE,
outline = FALSE,
clearable = TRUE
)) {
inputTag <- createInputTag(
inputId = inputId,
value = value,
type = "text",
placeholder = placeholder
)
do.call(
createInputLayout,
list(
inputTag,
label = label,
style = style
)
)
}
#' Update Framework7 text input
#'
#' \code{updateF7Text} changes the value of a text input on the client.
#'
#' @param session The Shiny session object, usually the default value will suffice.
#' @note Updating label does not work yet.
#' @export
#' @rdname text
updateF7Text <- function(
inputId, label = NULL, value = NULL, placeholder = NULL,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(label = label, value = value, placeholder = placeholder))
session$sendInputMessage(inputId, message)
}
#' Framework7 text area input
#'
#' \code{f7TextArea} creates a f7 text area input.
#'
#' @param resize Whether to box can be resized. Default to FALSE.
#'
#' @export
#' @rdname text
f7TextArea <- function(inputId, label, value = "", placeholder = NULL,
resize = FALSE, style = list(
media = NULL,
description = NULL,
floating = FALSE,
outline = FALSE,
clearable = TRUE
)) {
inputTag <- createInputTag(
inputId = inputId,
value = value,
type = "textarea",
placeholder = placeholder,
class = if (resize) "resizable" else NULL
)
do.call(
createInputLayout,
list(
inputTag,
label = label,
style = style
)
)
}
#' Update Framework7 text area input
#'
#' \code{updateF7TextArea} changes the value of a text area input on the client.
#'
#' @rdname text
#' @export
updateF7TextArea <- updateF7Text
#' Create an f7 password input
#'
#' \link{f7Password} creates a password input.
#'
#' @export
#' @rdname text
f7Password <- function(
inputId, label, placeholder = NULL,
style = list(
media = NULL,
description = NULL,
floating = FALSE,
outline = FALSE,
clearable = TRUE
)) {
inputTag <- createInputTag(
inputId = inputId,
type = "password",
placeholder = placeholder
)
do.call(
createInputLayout,
list(
inputTag,
label = label,
style = style
)
)
}
#' Framework7 range slider
#'
#' \code{f7Slider} creates a f7 slider input.
#'
#' @param inputId Slider input id.
#' @param label Slider label.
#' @param min Slider minimum range.
#' @param max Slider maximum range.
#' @param value Slider value or a vector containing 2 values (for a range).
#' @param step Slider increase step size.
#' @param scale Slider scale.
#' @param scaleSteps Number of scale steps.
#' @param scaleSubSteps Number of scale sub steps (each step will be divided by this value).
#' @param vertical Whether to apply a vertical display. FALSE by default.
#' @param verticalReversed Makes vertical range slider reversed (vertical must be also enabled).
#' FALSE by default.
#' @param labels Enables additional label around range slider knob. List of 2 \link{f7Icon}
#' expected.
#' @param color See \link{getF7Colors} for valid colors.
#' @param noSwipping Prevent swiping when slider is manipulated in an \link{f7TabLayout}.
#' @param showLabel Allow bubble containing the slider value. Default
#' to TRUE.
#' @param ... Other options to pass to the widget. See
#' \url{https://framework7.io/docs/range-slider#range-slider-parameters}.
#' @param style Allows to style the input. inset, outline and strong are available.
#'
#' @note labels option only works when vertical is FALSE!
#'
#' @rdname slider
#'
#' @export
#'
#' @example inst/examples/slider/app.R
f7Slider <- function(inputId, label, min, max, value, step = 1, scale = FALSE,
scaleSteps = 5, scaleSubSteps = 0, vertical = FALSE,
verticalReversed = FALSE, labels = NULL, color = NULL,
noSwipping = TRUE, showLabel = TRUE, ...,
style = list(
inset = FALSE,
outline = FALSE,
strong = FALSE
)) {
if (!is.null(labels)) {
if (length(labels) < 2) stop("labels must be a tagList with 2 elements.")
}
sliderCl <- "range-slider"
if (!is.null(color)) sliderCl <- paste0(sliderCl, " color-", color)
if (isTRUE(noSwipping)) {
sliderCl <- paste(sliderCl, "swiper-no-swiping")
}
config <- dropNulls(
list(
dual = if (length(value) == 2) TRUE else FALSE,
min = min,
max = max,
vertical = vertical,
verticalReversed = if (vertical) verticalReversed,
label = showLabel,
step = step,
value = value,
scale = scale,
scaleSteps = scaleSteps,
scaleSubSteps = scaleSubSteps
)
)
# wrap props
rangeTag <- shiny::tags$div(
class = sliderCl,
id = inputId,
style = if (vertical) {
if (scale) {
"height: 160px; margin: 20px;"
} else {
"height: 160px;"
}
} else {
NULL
},
buildConfig(inputId, config)
)
labels <- if (!is.null(labels)) {
lapply(seq_along(labels), function(i) {
isF7Icon <- grepl(x = labels[[i]]$attribs$class, pattern = "f7-icons")
if (!inherits(labels[[i]], "shiny.tag") || !isF7Icon) {
stop("Label must be a f7Icon.")
}
shiny::tags$div(
labels[[i]]
)
})
}
# wrapper
shiny::tagList(
# HTML skeleton
shiny::tags$div(class = "block-title", label),
if (!is.null(labels)) {
f7List(
mode = "simple",
inset = style$inset,
outline = style$outline,
strong = style$strong,
shiny::tags$li(
labels[[1]],
shiny::tags$div(
style = "width: 100%; margin: 0 16px",
rangeTag
),
labels[[2]]
)
)
} else {
f7Block(
inset = style$inset,
outline = style$outline,
strong = style$strong,
rangeTag
)
}
)
}
#' Update Framework7 range slider
#'
#' \code{updateF7Slider} changes the value of a slider input on the client.
#'
#' @param session The Shiny session object.
#'
#' @export
#' @rdname slider
#'
#' @note Important: you cannot transform a range slider into a simple slider and inversely.
updateF7Slider <- function(inputId, min = NULL, max = NULL, value = NULL,
scale = FALSE, scaleSteps = NULL, scaleSubSteps = NULL,
step = NULL, color = NULL, ...,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(
value = value,
min = min,
max = max,
scale = scale,
step = step,
scaleSteps = scaleSteps,
scaleSubSteps = scaleSubSteps,
color = color,
...
))
session$sendInputMessage(inputId, message)
}
#' Framework7 stepper input
#'
#' \code{f7Stepper} creates a stepper input.
#'
#' @param inputId Stepper input id.
#' @param label Stepper label.
#' @param min Stepper minimum value.
#' @param max Stepper maximum value.
#' @param value Stepper value. Must belong to \code{\[min, max\]}.
#' @param step Increment step. 1 by default.
#' @param fill Whether to fill the stepper. FALSE by default.
#' @param rounded Whether to round the stepper. FALSE by default.
#' @param raised Whether to put a relied around the stepper. FALSE by default.
#' @param size Stepper size: "small", "large" or NULL.
#' @param color Stepper color: NULL or "red", "green", "blue", "pink", "yellow", "orange", "grey" and "black".
#' @param wraps In wraps mode incrementing beyond maximum value sets value to minimum value,
#' likewise, decrementing below minimum value sets value to maximum value. FALSE by default.
#' @param autorepeat Pressing and holding one of its buttons increments or decrements the stepper’s
#' value repeatedly. With dynamic autorepeat, the rate of change depends on how long the user
#' continues pressing the control. TRUE by default.
#' @param manual It is possible to enter value manually from keyboard or mobile keypad. When click on
#' input field, stepper enter into manual input mode, which allow type value from keyboar and check
#' fractional part with defined accurancy. Click outside or enter Return key, ending manual mode.
#' TRUE by default.
#' @param decimalPoint Number of digits after dot, when in manual input mode.
#' @param buttonsEndInputMode Disables manual input mode on Stepper's minus or plus button click.
#'
#' @rdname stepper
#' @example inst/examples/stepper/app.R
#' @export
f7Stepper <- function(inputId, label, min, max, value, step = 1,
fill = FALSE, rounded = FALSE, raised = FALSE, size = NULL,
color = NULL, wraps = FALSE, autorepeat = TRUE, manual = FALSE,
decimalPoint = 4, buttonsEndInputMode = TRUE) {
stepperCl <- "stepper"
if (fill) stepperCl <- paste(stepperCl, "stepper-fill")
if (rounded) stepperCl <- paste(stepperCl, "stepper-round")
if (!is.null(size)) {
stepperCl <- paste0(stepperCl, " stepper-", size)
}
if (raised) stepperCl <- paste(stepperCl, "stepper-raised")
if (!is.null(color)) stepperCl <- paste0(stepperCl, " color-", color)
# stepper props
config <- dropNulls(
list(
min = min,
max = max,
step = step,
value = value,
decimalPoint = decimalPoint,
wraps = wraps,
autorepeat = autorepeat,
autorepeatDynamic = autorepeat,
manualInputMode = manual,
buttonsEndInputMode = buttonsEndInputMode
)
)
# wrap props
stepperTag <- shiny::tags$div(
class = stepperCl,
id = inputId,
buildConfig(inputId, config)
)
stepperTag <- shiny::tagAppendChildren(
stepperTag,
shiny::tags$div(class = "stepper-button-minus"),
shiny::tags$div(
class = "stepper-input-wrap",
shiny::tags$input(
type = "text",
value = value,
min = min,
max = max,
step = step
)
),
shiny::tags$div(class = "stepper-button-plus")
)
# if not wrapped inside f7List, return "standalone" toggle
if (!is_wrapped()) {
shiny::div(
# stepper tag
style = "display: flex; align-items: center;",
shiny::tags$small(label, style = "padding: 5px"),
stepperTag
)
} else {
listify(
f7ListItem(
title = label,
right = stepperTag
)
)
}
}
#' Update Framework7 stepper
#'
#' \code{updateF7Stepper} changes the value of a stepper input on the client.
#'
#' @param session The Shiny session object, usually the default value will suffice.
#'
#' @export
#' @rdname stepper
#'
#' @note While updating, the autorepeat field does not work correctly.
updateF7Stepper <- function(inputId, min = NULL, max = NULL,
value = NULL, step = NULL, fill = NULL,
rounded = NULL, raised = NULL, size = NULL,
color = NULL, wraps = NULL, decimalPoint = NULL,
autorepeat = NULL, manual = NULL,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(
min = min,
max = max,
value = value,
step = step,
fill = fill,
rounded = rounded,
raised = raised,
size = size,
color = color,
wraps = wraps,
decimalPoint = decimalPoint,
autorepeat = autorepeat,
manual = manual
))
session$sendInputMessage(inputId, message)
}
#' Framework7 toggle input
#'
#' \code{f7Toggle} creates a F7 toggle switch input.
#'
#' @param inputId Toggle input id.
#' @param label Toggle label.
#' @param checked Whether to check the toggle. FALSE by default.
#' @param color
#' Toggle color: NULL or "primary", "red", "green", "blue",
#' "pink", "yellow", "orange", "purple", "deeppurple", "lightblue",
#' "teal, "lime", "deeporange", "gray", "white", "black".
#'
#' @rdname toggle
#' @example inst/examples/toggle/app.R
#' @export
f7Toggle <- function(inputId, label, checked = FALSE, color = NULL) {
toggleCl <- "toggle"
if (!is.null(color)) toggleCl <- paste0(toggleCl, " color-", color)
toggleInnerTag <-
shiny::tags$label(
class = toggleCl,
id = inputId,
shiny::tags$input(
type = "checkbox",
checked = if (checked) NA else NULL
),
shiny::tags$span(class = "toggle-icon")
)
# if not wrapped inside f7List, return "standalone" toggle
if (!is_wrapped()) {
tagList(
shiny::tags$span(label,
style = "padding: 5px"
),
toggleInnerTag
)
} else {
listify(
f7ListItem(
title = label,
right = toggleInnerTag
)
)
}
}
#' Update Framework7 toggle input
#'
#' \code{updateF7Toggle} changes the value of a toggle input on the client.
#'
#' @param session The Shiny session object.
#'
#' @export
#' @rdname toggle
updateF7Toggle <- function(inputId, checked = NULL, color = NULL,
session = shiny::getDefaultReactiveDomain()) {
message <- dropNulls(list(
checked = checked,
color = color
))
session$sendInputMessage(inputId, message)
}
#' Framework7 radio input
#'
#' \code{f7Radio} creates a radio button input.
#'
#' @inheritParams f7GroupInput
#'
#' @export
#' @rdname radio
#' @example inst/examples/radio/app.R
f7Radio <- function(
inputId, label, choices = NULL, selected = NULL,
position = c("left", "right"), style = list(
inset = FALSE,
outline = FALSE, dividers = FALSE, strong = FALSE
)) {
position <- match.arg(position)
f7GroupInput(
type = "radio",
inputId = inputId,
label = label,
choices = choices,
selected = selected,
position = position,
style = style
)
}
#' Update Framework7 radio buttons
#'
#' \code{updateF7Radio} updates a radio button input.
#'
#' @param session Shiny session object.
#'
#' @rdname radio
#' @export
updateF7Radio <- function(inputId, label = NULL, choices = NULL,
selected = NULL, session = shiny::getDefaultReactiveDomain()) {
if (is.null(selected)) {
if (!is.null(choices)) {
selected <- choices[[1]]
}
}
options <- NULL
if (!is.null(choices)) {
options <- as.character(
shiny::tags$ul(
createOptions(inputId, choices, selected, type = "radio")
)
)
}
message <- dropNulls(
list(
label = label,
options = options,
value = selected
)
)
session$sendInputMessage(inputId, message)
}
#' @export
#' @inheritParams f7CheckboxChoice
#' @rdname radio
f7RadioChoice <- f7CheckboxChoice
#' Group input default options
#'
#' @keywords internal
groupInputDefaults <- function() {
style = list(
inset = FALSE,
outline = FALSE,
dividers = FALSE,
strong = FALSE
)
}
#' Framework7 group input
#'
#' Useful to create \code{f7Radio} and \link{f7CheckboxGroup}.
#'
#' @param inputId Input id.
#' @param label Input label
#' @param choices List of choices. Can be a simple
#' vector or named list or a list of \link{f7RadioChoice} or
#' \link{f7CheckboxChoice}
#' @param selected Selected element. NULL by default. If you pass
#' \link{f7RadioChoice} or \link{f7CheckboxChoice} in choices,
#' selected must be a numeric value corresponding to the index of the element to select.
#' @param position Check mark side.
#' \code{"left"} or \code{"right"}.
#' @param style Input style. Inherit from \link{f7List} options
#' such as outline, inset, strong and dividers.
#'
#' @importFrom utils modifyList
#'
#' @keywords internal
f7GroupInput <- function(
type, inputId, label, choices, selected, position, style) {
# make sure style does contain all defaults
# this prevents an error when the users only provides
# a subset of the style options
style <- modifyList(groupInputDefaults(), style)
has_media_list <- inherits(choices[[1]], "custom_choice")
mainCl <- sprintf("shiny-input-%sgroup", type)
position <- switch(position,
"left" = "start",
"right" = "end"
)
tmp <- f7List(
mode = if (has_media_list) "media" else NULL,
inset = style$inset,
outline = style$outline,
dividers = style$dividers,
strong = style$strong,
createOptions(
inputId,
choices,
selected,
position,
has_media_list,
type = type
)
)
tmp$attribs$id <- inputId
tmp$attribs$class <- paste(
tmp$attribs$class,
mainCl
)
shiny::tagList(
shiny::tags$div(
class = "block-title",
label
),
tmp
)
}
#' Generates a list of option
#'
#' For \link{f7Radio} and \link{f7CheckboxGroup}
#'
#' @param inputId Radio input id.
#' @param choices List of choices.
#' @param selected Selected value
#' @param position Check mark position.
#' @param has_media_list For custom choices.
#' @param type Choose either "checkbox" or "radio"
#'
#' @keywords internal
createOptions <- function(
inputId, choices, selected,
position = "start", has_media_list = FALSE, type) {
if (has_media_list) position <- "start"
selectedPosition <- NULL
selectedPosition <- if (!is.null(selected)) {
if (has_media_list) {
if (!is.numeric(selected) || selected > length(choices)) {
stop("When using f7*Choice (Radio or Checkbox),
selected must be a numeric value of the choice to select.
selected can't be higher than the total number of choices.")
}
selected
} else {
match(selected, choices)
}
}
lapply(X = seq_along(choices), function(i) {
shiny::tags$li(
shiny::tags$label(
class = sprintf(
"item-%s item-%s-icon-%s item-content",
type,
type,
position
),
shiny::tags$input(
type = type,
name = inputId,
value = if (has_media_list) {
names(choices)[[i]] %OR% i
} else {
choices[[i]]
},
checked = if (!is.null(selectedPosition)) {
if (i == selectedPosition) NA
}
),
shiny::tags$i(class = sprintf("icon icon-%s", type)),
shiny::tags$div(
class = "item-inner",
if (has_media_list) {
choices[[i]]
} else {
shiny::tags$div(class = "item-title", choices[[i]])
}
)
)
)
})
}
#' Creates an input form
#'
#' Instead of having shiny return one input
#' at a time, a form is a collection of related inputs.
#' The form returns a list with all sub-inputs as elements.
#' This avoids to have to deal with too many inputs.
#'
#' This only works with elements having
#' an input HTML tag.
#'
#' @param id Form unique id. Using `input$<id>` gives
#' the form result.
#' @param ... A list of input elements.
#'
#' @export
#' @rdname form-inputs
#' @example inst/examples/forms/app.R
f7Form <- function(id, ...) {
inputs <- list(...)
# All inputs must have a name + no binding
inputs <- lapply(inputs, function(input) {
# Test for different input types
valid_inputs <- c("input", "textarea", "select")
target <- NULL
for (el in valid_inputs) {
tmp <- htmltools::tagQuery(input)$
find(el)$
selectedTags()
if (length(tmp) > 0) target <- el
}
query <- htmltools::tagQuery(input)$
find(target)
id <- query$
selectedTags()[[1]]$
attribs$id
query$
addAttrs(
name = id,
`data-shiny-no-bind-input` = NA
)$allTags()
})
shiny::tags$form(class = "inputs-form", id = id, inputs)
}
#' Update a form on the server
#'
#' \link{updateF7Form} update form inputs on the server.
#'
#' @param data New form data.
#' @param session Shiny session objects.
#' @rdname form-inputs
#' @export
updateF7Form <- function(id, data, session = shiny::getDefaultReactiveDomain()) {
session$sendInputMessage(id, data)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.