' +
+ return '
' +
'
' +
escape(item.data.name) + ' ' +
'
' +
@@ -54,7 +57,7 @@ columnSelectInput <- function(inputId, label, data, selected = "", ...,
},
// avoid data vomit splashing on screen when an option is selected
- item: function(item, escape) { return ''; }
+ item: function(item, escape) { return ''; }
}")),
# fix for highlight persisting
diff --git a/R/selectInput_proportion.R b/R/selectInput_proportion.R
index f0162cf..ee0d8fa 100644
--- a/R/selectInput_proportion.R
+++ b/R/selectInput_proportion.R
@@ -53,7 +53,7 @@ proportionSelectInput <- function(inputId, label, vec, selected = "", ...,
// format the way that options are rendered
option: function(item, escape) {
item.data = JSON.parse(item.label);
- return '' +
+ return '' +
'' +
'' +
escape(item.data.name) + ' ' +
diff --git a/R/shiny_data_filter.R b/R/shiny_data_filter.R
index 3bc65fe..5ee1b1c 100644
--- a/R/shiny_data_filter.R
+++ b/R/shiny_data_filter.R
@@ -13,6 +13,7 @@
#' @inherit shiny_data_filter examples
#'
shiny_data_filter_ui <- function(inputId) {
+ .Deprecated("IDEAFilter_ui")
ns <- shiny::NS(inputId)
shinyDataFilter_resourcePath()
@@ -118,6 +119,7 @@ shiny_data_filter_ui <- function(inputId) {
#' }
#'
shiny_data_filter <- function(input, output, session, data, verbose = FALSE) {
+ .Deprecated("IDEAFilter")
ns <- session$ns
filter_log("calling module", verbose = verbose)
@@ -153,12 +155,17 @@ shiny_data_filter <- function(input, output, session, data, verbose = FALSE) {
filter_returns[[fid]]$destroy
}
- filter_returns[[fid]] <<- callModule(
- shiny_data_filter_item,
- fid,
- data = filter_returns[[in_fid]]$data,
- column_name = column_name,
- verbose = verbose)
+ filter_returns[[fid]] <<- withCallingHandlers(callModule(
+ shiny_data_filter_item,
+ fid,
+ data = filter_returns[[in_fid]]$data,
+ column_name = column_name,
+ verbose = verbose),
+ warning = function(w) {
+ if (inherits(w, "deprecatedWarning") && grepl("IDEAFilter_item", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ }
+ )
}
output$add_filter_select_ui <- renderUI({
@@ -195,7 +202,14 @@ shiny_data_filter <- function(input, output, session, data, verbose = FALSE) {
insertUI(
selector = sprintf("#%s", ns("sortableList")),
where = "beforeEnd",
- ui = shiny_data_filter_item_ui(ns(fid), verbose = verbose))
+ ui = withCallingHandlers(
+ shiny_data_filter_item_ui(ns(fid), verbose = verbose),
+ warning = function(w) {
+ if (inherits(w, "deprecatedWarning") && grepl("IDEAFilter_item", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ }
+ )
+ )
})
observeEvent(input$add_filter_select, {
@@ -208,7 +222,14 @@ shiny_data_filter <- function(input, output, session, data, verbose = FALSE) {
insertUI(
selector = sprintf("#%s", ns("sortableList")),
where = "beforeEnd",
- ui = shiny_data_filter_item_ui(ns(fid), verbose = verbose))
+ ui = withCallingHandlers(
+ shiny_data_filter_item_ui(ns(fid), verbose = verbose),
+ warning = function(w) {
+ if (inherits(w, "deprecatedWarning") && grepl("IDEAFilter_item", conditionMessage(w)))
+ invokeRestart("muffleWarning")
+ }
+ )
+ )
updateSelectInput(session, "add_filter_select", selected = "")
}, ignoreInit = TRUE, ignoreNULL = TRUE)
@@ -247,8 +268,8 @@ shiny_data_filter <- function(input, output, session, data, verbose = FALSE) {
reactive({
filter_log("recalculating filtered data", verbose = verbose)
structure(
- d <- filter_returns[[utils::tail(filters(), 1)]]$data(),
+ d <- filter_returns[[utils::tail(filters(), 1)]]$data() %||% data.frame(),
code = code(),
class = c("shinyDataFilter_df", class(d)))
})
-}
\ No newline at end of file
+}
diff --git a/R/shiny_data_filter_item.R b/R/shiny_data_filter_item.R
index 329e2ed..41a8f66 100644
--- a/R/shiny_data_filter_item.R
+++ b/R/shiny_data_filter_item.R
@@ -18,6 +18,7 @@
#' @keywords internal
#'
shiny_data_filter_item_ui <- function(inputId, verbose = FALSE) {
+ .Deprecated("IDEAFilter_item_ui")
ns <- shiny::NS(inputId)
shiny::uiOutput(ns("ui"),
class = "list-group-item well",
@@ -54,6 +55,7 @@ shiny_data_filter_item_ui <- function(inputId, verbose = FALSE) {
#'
shiny_data_filter_item <- function(input, output, session, data,
column_name = NULL, verbose = FALSE) {
+ .Deprecated("IDEAFilter_item")
ns <- session$ns
@@ -163,10 +165,14 @@ shiny_data_filter_item <- function(input, output, session, data,
shiny::observeEvent(input$column_select_edit_btn, {
module_return$column_name <- NULL
+ remove_shiny_inputs("vector_filter", input, ns = ns)
+ try(session$userData$eraser_observer$destroy(), silent = TRUE)
})
shiny::observeEvent(input$remove_filter_btn, {
module_return$remove <- TRUE
+ remove_shiny_inputs("vector_filter", input, ns = ns)
+ try(session$userData$eraser_observer$destroy(), silent = TRUE)
})
vector_module_srv <- shiny::reactive(shiny_vector_filter(vec(), "vec"))
@@ -202,4 +208,4 @@ shiny_data_filter_item <- function(input, output, session, data,
})
module_return
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter.R b/R/shiny_vector_filter.R
index f6d1307..6e57ed7 100644
--- a/R/shiny_vector_filter.R
+++ b/R/shiny_vector_filter.R
@@ -106,7 +106,8 @@ shiny_vector_filter <- function(data, inputId, global = FALSE) {
#' @keywords internal
shiny_vector_filter.default <- function(data, inputId, ...) {
function(input, output, session, x = shiny::reactive(NULL),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
module_return <- shiny::reactiveValues(code = FALSE, mask = FALSE)
module_return$code <- shiny::reactive(FALSE)
@@ -125,7 +126,7 @@ shiny_vector_filter.default <- function(data, inputId, ...) {
#'
#' @return a pillar formatted class name
#'
-#' @importFrom pillar new_pillar_type
+#' @importFrom pillar type_sum
#' @keywords internal
#'
get_dataFilter_class <- function(obj) {
@@ -139,5 +140,6 @@ get_dataFilter_class <- function(obj) {
if (!length(vf_class)) return("unk")
class(obj) <- vf_class
- pillar::new_pillar_type(obj)[[1]][1]
-}
\ No newline at end of file
+ type <- pillar::type_sum(obj)
+ if (length(type) == 0L) "" else type
+}
diff --git a/R/shiny_vector_filter_NULL.R b/R/shiny_vector_filter_NULL.R
index 10ea625..2eeb202 100644
--- a/R/shiny_vector_filter_NULL.R
+++ b/R/shiny_vector_filter_NULL.R
@@ -11,7 +11,8 @@ shiny_vector_filter_ui.NULL = function(data, inputId) {
#' @keywords internal
shiny_vector_filter.NULL <- function(data, inputId, ...) {
function(input, output, session, x = shiny::reactive(NULL),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
module_return$code <- shiny::reactive(TRUE)
@@ -19,4 +20,4 @@ shiny_vector_filter.NULL <- function(data, inputId, ...) {
module_return
}
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_character.R b/R/shiny_vector_filter_character.R
index 28447be..998a6c0 100644
--- a/R/shiny_vector_filter_character.R
+++ b/R/shiny_vector_filter_character.R
@@ -11,7 +11,8 @@ shiny_vector_filter_ui.character <- function(data, inputId) {
#' @keywords internal
shiny_vector_filter.character <- function(data, inputId, ...) {
function(input, output, session, x = shiny::reactive(character()),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
@@ -19,12 +20,15 @@ shiny_vector_filter.character <- function(data, inputId, ...) {
x_wo_NAs <- shiny::reactive(Filter(Negate(is.na), x()))
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) FALSE else purrr::possibly(filter_fn, otherwise = FALSE)
+
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
output$ui <- shiny::renderUI({
filter_log("updating ui", verbose = verbose)
- if (purrr::reduce(purrr::map(x(), is.empty), `&`)) {
+ if (purrr::reduce(purrr::map(x(), is.empty), `&`, .init = TRUE)) {
shiny::div(style = "opacity: 0.5;",
p(width = "100%",
align = "center",
@@ -32,12 +36,18 @@ shiny_vector_filter.character <- function(data, inputId, ...) {
} else {
proportionSelectInput(ns("param"), NULL,
vec = x,
- selected = shiny::isolate(input$param) %||% c(),
+ selected = isolate(input$param) %||% x_filtered,
multiple = TRUE,
width = "100%")
}
})
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateSelectizeInput(session, "param", selected = ""),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
if (length(input$param))
@@ -53,4 +63,4 @@ shiny_vector_filter.character <- function(data, inputId, ...) {
})
module_return
}
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_date.R b/R/shiny_vector_filter_date.R
index a9d1396..d4e7704 100644
--- a/R/shiny_vector_filter_date.R
+++ b/R/shiny_vector_filter_date.R
@@ -12,10 +12,14 @@ shiny_vector_filter_ui.Date <- function(data, inputId) {
#' @keywords internal
shiny_vector_filter.Date <- function(data, inputId, ...) {
function(input, output, session, x = shiny::reactive(Date()),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) TRUE else purrr::possibly(filter_fn, otherwise = TRUE)
+
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
output$ui <- shiny::renderUI({
filter_log("updating ui", verbose = verbose)
@@ -28,10 +32,11 @@ shiny_vector_filter.Date <- function(data, inputId, ...) {
0.5s ease-in 0s 1 shinyDataFilterFadeIn;
transform-origin: bottom;"),
if (any(!is.na(x()))) {
+ my_min_date <- if (is.null(isolate(input$param))) NULL else max(isolate(input$param[[1]]), min(x(), na.rm = TRUE))
+ my_max_date <- if (is.null(isolate(input$param))) NULL else min(isolate(input$param[[2]]), max(x(), na.rm = TRUE))
shiny::dateRangeInput(ns("param"), NULL,
- #value = shiny::isolate(input$param) %||% range(x(), na.rm = TRUE),
- start = min(x(), na.rm = TRUE),
- end = max(x(), na.rm = TRUE),
+ start = my_min_date %||% min(x_filtered),
+ end = my_max_date %||% max(x_filtered),
min = min(x(), na.rm = TRUE),
max = max(x(), na.rm = TRUE)
)
@@ -41,6 +46,12 @@ shiny_vector_filter.Date <- function(data, inputId, ...) {
shiny::tags$h5(shiny::tags$i("no numeric values")))
})
})
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateDateRangeInput(session, "param", start = min(x(), na.rm = TRUE), end = max(x(), na.rm = TRUE)),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
exprs <- list()
@@ -73,4 +84,4 @@ shiny_vector_filter.Date <- function(data, inputId, ...) {
module_return
}
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_datetime.R b/R/shiny_vector_filter_datetime.R
index d16d388..29f7b9f 100644
--- a/R/shiny_vector_filter_datetime.R
+++ b/R/shiny_vector_filter_datetime.R
@@ -1,4 +1,4 @@
-#' @importFrom shinyTime timeInput
+#' @importFrom shinyTime timeInput updateTimeInput
#' @importFrom shiny NS uiOutput
#' @export
#' @keywords internal
@@ -12,15 +12,17 @@ shiny_vector_filter_ui.POSIXct <- function(data, inputId) {
#' @keywords internal
shiny_vector_filter.POSIXct <- function(data, inputId, ...) {
function(input, output, session, x = shiny::reactive(),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) TRUE else purrr::possibly(filter_fn, otherwise = TRUE)
- p <- reactive({
- as.POSIXct(x(), origin = "1970-01-01 00:00:00", tz = "GMT")
- })
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
+ tzone <- reactive(attr(x(), "tzone") %||% "")
+
output$ui <- shiny::renderUI({
filter_log("updating ui", verbose = verbose)
shiny::div(
@@ -32,18 +34,22 @@ shiny_vector_filter.POSIXct <- function(data, inputId, ...) {
0.5s ease-in 0s 1 shinyDataFilterFadeIn;
transform-origin: bottom;"),
if (any(!is.na(x()))) {
- my_date <- as.Date(p())
+ my_date <- as.Date(x())
+ my_min_date <- if (is.null(isolate(input$st_date))) NULL else max(isolate(input$st_date), min(my_date, na.rm = TRUE))
+ my_min_time <- if (is.null(isolate(input$st_time))) NULL else max(isolate(st_dt()), min(x(), na.rm = TRUE))
+ my_max_date <- if (is.null(isolate(input$end_date))) NULL else min(isolate(input$end_date), max(my_date, na.rm = TRUE))
+ my_max_time <- if (is.null(isolate(input$end_time))) NULL else min(isolate(end_dt()), max(x(), na.rm = TRUE))
div(
div(style = "display: inline-block; vertical-align:middle;",
- shiny::dateInput(ns("st_date"), "Start Date",value = min(my_date, na.rm = TRUE)
+ shiny::dateInput(ns("st_date"), "Start Date", value = my_min_date %||% min(as.Date(x_filtered))
, min = min(my_date, na.rm = TRUE), max = max(my_date, na.rm = TRUE)),
- shinyTime::timeInput(ns("st_time"), "Start Time (HH:MM:SS)", value = min(p(), na.rm = TRUE))# automatically takes the time element
+ shinyTime::timeInput(ns("st_time"), "Start Time (HH:MM:SS)", value = my_min_time %||% min(x_filtered))# automatically takes the time element
),
div(style = "display: inline-block; vertical-align:middle;",
- shiny::dateInput(ns("end_date"), "End Date",value = max(my_date, na.rm = TRUE)
+ shiny::dateInput(ns("end_date"), "End Date", value = my_max_date %||% max(as.Date(x_filtered))
, min = min(my_date, na.rm = TRUE), max = max(my_date, na.rm = TRUE)),
- shinyTime::timeInput(ns("end_time"), "End Time (HH:MM:SS)", value = max(p(), na.rm = TRUE)) # automatically takes the time element
+ shinyTime::timeInput(ns("end_time"), "End Time (HH:MM:SS)", value = my_max_time %||% max(x_filtered)) # automatically takes the time element
)
)
} else {
@@ -53,22 +59,31 @@ shiny_vector_filter.POSIXct <- function(data, inputId, ...) {
})
})
+ session$userData$eraser_observer <-
+ observeEvent(erase_filters(), {
+ my_date <- as.Date(x())
+ updateDateInput(session, "st_date", value = min(my_date, na.rm = TRUE))
+ shinyTime::updateTimeInput(session, "st_time", value = min(x(), na.rm = TRUE))
+ updateDateInput(session, "end_date", value = max(my_date, na.rm = TRUE))
+ shinyTime::updateTimeInput(session, "end_time", value = max(x(), na.rm = TRUE))
+ }, ignoreInit = TRUE)
+
st_dt <- reactive({
- st <- substr(strftime(input$st_time, "%Y-%m-%d %H:%M:%S", tz = "GMT"),12,20)
- as.POSIXct(paste(input$st_date, st), tz = "GMT")
+ st <- substr(strftime(input$st_time, "%Y-%m-%d %H:%M:%S", tz = tzone()),12,20)
+ as.POSIXct(paste(input$st_date, st), tz = tzone())
})
end_dt <- reactive({
- end <- substr(strftime(input$end_time, "%Y-%m-%d %H:%M:%S", tz = "GMT"),12,20)
- as.POSIXct(paste(input$end_date, end), tz = "GMT")
+ end <- substr(strftime(input$end_time, "%Y-%m-%d %H:%M:%S", tz = tzone()),12,20)
+ as.POSIXct(paste(input$end_date, end), tz = tzone())
})
module_return$code <- shiny::reactive({
exprs <- list()
-
+
if (!is.null(input$st_date) & !is.null(input$st_time) & !is.null(input$end_date) & !is.null(input$end_time)) {
- if (st_dt() > min(p(), na.rm = TRUE))
+ if (st_dt() > min(x(), na.rm = TRUE))
exprs <- append(exprs, bquote(.x >= .(st_dt())))
- if (end_dt() < max(p(), na.rm = TRUE))
+ if (end_dt() < max(x(), na.rm = TRUE))
exprs <- append(exprs, bquote(.x <= .(end_dt())))
}
@@ -93,4 +108,4 @@ shiny_vector_filter.POSIXct <- function(data, inputId, ...) {
module_return
}
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_factor_few.R b/R/shiny_vector_filter_factor_few.R
index 5667353..db8c781 100644
--- a/R/shiny_vector_filter_factor_few.R
+++ b/R/shiny_vector_filter_factor_few.R
@@ -9,6 +9,10 @@
#' @param x a reactive expression resolving to the vector to filter
#' @param filter_na a logical value indicating whether to filter \code{NA}
#' values from the \code{x} vector
+#' @param filter_fn A function to modify, specified in one of the following ways:
+#' * A named function, e.g. `mean`.
+#' * An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+#' * A formula, e.g. `~ .x + 1`.
#' @param verbose a \code{logical} value indicating whether or not to print log
#' statements out to the console
#'
@@ -23,13 +27,17 @@
#' @importFrom grDevices rgb
#' @keywords internal
shiny_vector_filter_factor_few <- function(input, output, session,
- x = shiny::reactive(factor()), filter_na = shiny::reactive(TRUE),
- verbose = FALSE) {
+ x = shiny::reactive(factor()), filter_na = shiny::reactive(TRUE), filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
x_wo_NA <- shiny::reactive(Filter(Negate(is.na), x()))
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) FALSE else purrr::possibly(filter_fn, otherwise = FALSE)
+
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
choices <- shiny::reactive(unique(as.character(x_wo_NA())))
@@ -46,25 +54,15 @@ shiny_vector_filter_factor_few <- function(input, output, session,
),
shiny::checkboxGroupInput(ns("param"), NULL,
choices = choices(),
- selected = shiny::isolate(input$param) %||% c(),
+ selected = isolate(input$param) %||% x_filtered,
width = "100%"))
})
-
- # Normalized
- # ggplot2::ggplot() +
- # # sort factor so that it reflects checkbox order
- # ggplot2::aes(x = factor(
- # as.character(x_wo_NA()),
- # levels = rev(choices()))) +
- # ggplot2::geom_bar(
- # width = 0.95,
- # fill = grDevices::rgb(66/255, 139/255, 202/255),
- # color = NA,
- # alpha = 0.2) +
- # ggplot2::coord_flip() +
- # ggplot2::theme_void() +
- # ggplot2::scale_x_discrete(expand = c(0, 0)) +
- # ggplot2::scale_y_continuous(expand = c(0, 0))
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateCheckboxGroupInput(session, "param", selected = ""),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
if (length(input$param))
@@ -80,4 +78,4 @@ shiny_vector_filter_factor_few <- function(input, output, session,
})
module_return
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_factor_many.R b/R/shiny_vector_filter_factor_many.R
index 9e47bca..37a2694 100644
--- a/R/shiny_vector_filter_factor_many.R
+++ b/R/shiny_vector_filter_factor_many.R
@@ -9,6 +9,10 @@
#' @param x a reactive expression resolving to the vector to filter
#' @param filter_na a logical value indicating whether to filter \code{NA}
#' values from the \code{x} vector
+#' @param filter_fn A function to modify, specified in one of the following ways:
+#' * A named function, e.g. `mean`.
+#' * An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+#' * A formula, e.g. `~ .x + 1`.
#' @param verbose a \code{logical} value indicating whether or not to print log
#' statements out to the console
#'
@@ -19,22 +23,31 @@
#' @importFrom shiny reactive reactiveValues renderUI selectInput isolate
#' @keywords internal
shiny_vector_filter_factor_many <- function(input, output, session,
- x = shiny::reactive(factor()), filter_na = shiny::reactive(FALSE),
- verbose = FALSE) {
+ x = shiny::reactive(factor()), filter_na = shiny::reactive(FALSE), filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
x_wo_NAs <- shiny::reactive(Filter(Negate(is.na), x()))
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) FALSE else purrr::possibly(filter_fn, otherwise = FALSE)
+
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
output$ui <- shiny::renderUI({
filter_log("updating ui", verbose = verbose)
proportionSelectInput(ns("param"), NULL,
vec = x,
- selected = shiny::isolate(input$param) %||% c(),
+ selected = isolate(input$param) %||% x_filtered,
multiple = TRUE,
width = "100%")
})
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(), updateSelectizeInput(session, "param", selected = ""),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
if (length(input$param))
@@ -50,4 +63,4 @@ shiny_vector_filter_factor_many <- function(input, output, session,
})
module_return
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_logical.R b/R/shiny_vector_filter_logical.R
index 61005d9..31ddb3b 100644
--- a/R/shiny_vector_filter_logical.R
+++ b/R/shiny_vector_filter_logical.R
@@ -12,13 +12,18 @@ shiny_vector_filter_ui.logical <- function(data, inputId) {
#' @keywords internal
shiny_vector_filter.logical <- function(data, inputId, ...) {
function(input, output, session,
- x = shiny::reactive(logical()), filter_na = shiny::reactive(TRUE),
- verbose = FALSE) {
+ x = shiny::reactive(logical()), filter_na = shiny::reactive(TRUE), filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
- x_wo_NA <- shiny::reactive(Filter(Negate(is.na), x()))
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) FALSE else purrr::possibly(filter_fn, otherwise = FALSE)
+
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
+ filter_selected <- Filter(function(i) i %in% x_filtered, c("True" = TRUE, "False" = FALSE))
+
choices <- shiny::reactive({
Filter(function(i) i %in% x(), c("True" = TRUE, "False" = FALSE))
})
@@ -36,9 +41,15 @@ shiny_vector_filter.logical <- function(data, inputId, ...) {
shiny::plotOutput(ns("plot"), height = "100%")),
shiny::checkboxGroupInput(ns("param"), NULL,
choices = choices(),
- selected = shiny::isolate(input$param) %||% c(),
+ selected = isolate(input$param) %||% filter_selected,
width = "100%"))
})
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateCheckboxGroupInput(session, "param", selected = ""),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
exprs <- list()
@@ -48,7 +59,7 @@ shiny_vector_filter.logical <- function(data, inputId, ...) {
if (FALSE %in% input$param)
exprs <- append(exprs, list(quote(!.x)))
- if (length(input$param) == 2 && filter_na())
+ if (length(input$param) %% 2 == 0 && filter_na())
exprs <- list(quote(!is.na(.x)))
else if (length(input$param) && !filter_na())
exprs <- append(exprs, list(quote(is.na(.x))))
@@ -66,4 +77,4 @@ shiny_vector_filter.logical <- function(data, inputId, ...) {
module_return
}
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_numeric_few.R b/R/shiny_vector_filter_numeric_few.R
index b3c790c..da730c9 100644
--- a/R/shiny_vector_filter_numeric_few.R
+++ b/R/shiny_vector_filter_numeric_few.R
@@ -8,6 +8,10 @@
#' session
#' @param x The TODO
#' @param filter_na The \code{logical} TODO
+#' @param filter_fn A function to modify, specified in one of the following ways:
+#' * A named function, e.g. `mean`.
+#' * An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+#' * A formula, e.g. `~ .x + 1`.
#' @param verbose a \code{logical} value indicating whether or not to print log
#' statements out to the console
#'
@@ -25,12 +29,16 @@
#' @keywords internal
shiny_vector_filter_numeric_few <- function(input, output, session,
x = shiny::reactive(factor()), #important: changed x to factor here
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
x_wo_NA <- shiny::reactive(Filter(Negate(is.na), x()))
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) FALSE else purrr::possibly(filter_fn, otherwise = FALSE)
+
+ x_filtered <- unique(as.character(Filter(function(x) !is.na(x) & fn(x), x())))
choices <- shiny::reactive(unique(as.character(sort(x_wo_NA()))))
@@ -45,31 +53,21 @@ shiny_vector_filter_numeric_few <- function(input, output, session,
0.5s ease-in 0s 1 shinyDataFilterFadeIn;
transform-origin: left;" #,
),
- shiny::checkboxGroupInput(ns("param"), NULL,
+ shiny::checkboxGroupInput(ns("param_few"), NULL,
choices = choices(),
- selected = shiny::isolate(input$param) %||% c(),
+ selected = isolate(input$param_few) %||% x_filtered,
width = "100%"))
})
-
- # Normalized
- # ggplot2::ggplot() +
- # # sort factor so that it reflects checkbox order
- # ggplot2::aes(x = factor(
- # as.character(x_wo_NA()),
- # levels = rev(choices()))) +
- # ggplot2::geom_bar(
- # width = 0.95,
- # fill = grDevices::rgb(66/255, 139/255, 202/255),
- # color = NA,
- # alpha = 0.2) +
- # ggplot2::coord_flip() +
- # ggplot2::theme_void() +
- # ggplot2::scale_x_discrete(expand = c(0, 0)) +
- # ggplot2::scale_y_continuous(expand = c(0, 0))
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateCheckboxGroupInput(session, "param_few", selected = ""),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
- if (length(input$param))
- bquote(.x %in% .(c(if (filter_na()) c() else NA, input$param)))
+ if (length(input$param_few))
+ bquote(.x %in% .(c(if (filter_na()) c() else NA, input$param_few)))
else if (filter_na())
bquote(!is.na(.x))
else
@@ -81,4 +79,4 @@ shiny_vector_filter_numeric_few <- function(input, output, session,
})
module_return
-}
\ No newline at end of file
+}
diff --git a/R/shiny_vector_filter_numeric_many.R b/R/shiny_vector_filter_numeric_many.R
index fc180a5..526da85 100644
--- a/R/shiny_vector_filter_numeric_many.R
+++ b/R/shiny_vector_filter_numeric_many.R
@@ -8,6 +8,10 @@
#' session
#' @param x The TODO
#' @param filter_na The \code{logical} TODO
+#' @param filter_fn A function to modify, specified in one of the following ways:
+#' * A named function, e.g. `mean`.
+#' * An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+#' * A formula, e.g. `~ .x + 1`.
#' @param verbose a \code{logical} value indicating whether or not to print log
#' statements out to the console
#'
@@ -17,6 +21,7 @@
#' scale_y_continuous
#' @importFrom grDevices rgb
#' @importFrom stats density
+#' @importFrom purrr possibly
#'
#' @return a \code{\link[shiny]{reactiveValues}} list containing a logical
#' vector called "mask" which can be used to filter the provided vector and an
@@ -24,11 +29,14 @@
#' @export
#' @keywords internal
shiny_vector_filter_numeric_many <- function(input, output, session, x = shiny::reactive(numeric()),
- filter_na = shiny::reactive(FALSE), verbose = FALSE) {
+ filter_na = shiny::reactive(FALSE), filter_fn = NULL, verbose = FALSE,
+ erase_filters = shiny::reactive(0)) {
ns <- session$ns
module_return <- shiny::reactiveValues(code = TRUE, mask = TRUE)
+ fn <- if (is.null(filter_fn)) function(x) TRUE else purrr::possibly(filter_fn, otherwise = TRUE)
+ x_filtered <- Filter(function(x) !is.na(x) & fn(x), x())
output$ui <- shiny::renderUI({
filter_log("updating ui", verbose = verbose)
shiny::div(
@@ -40,25 +48,36 @@ shiny_vector_filter_numeric_many <- function(input, output, session, x = shiny::
0.5s ease-in 0s 1 shinyDataFilterFadeIn;
transform-origin: bottom;"),
if (any(!is.na(x()))) {
- shiny::sliderInput(ns("param"), NULL,
- value = shiny::isolate(input$param) %||% range(x(), na.rm = TRUE),
- min = min(round(x(), 1), na.rm = TRUE),
- max = max(round(x(), 1), na.rm = TRUE))
+ value_range <- range(isolate(input$param_many) %||% x_filtered)
+ overall_range <- range(x(), na.rm = TRUE)
+ value_range[1] <- min(max(value_range[1], overall_range[1]), overall_range[2])
+ value_range[2] <- max(min(value_range[2], overall_range[2]), overall_range[1])
+ shiny::sliderInput(ns("param_many"), NULL,
+ value = value_range,
+ min = overall_range[1],
+ max = overall_range[2])
} else {
shiny::div(
style = "padding-top: 10px; opacity: 0.3; text-align: center;",
shiny::tags$h5(shiny::tags$i("no numeric values")))
})
})
+ session$userData$eraser_observer <-
+ observeEvent(
+ erase_filters(),
+ updateSliderInput(session, "param_many", value = range(x(), na.rm = TRUE)),
+ ignoreInit = TRUE
+ )
module_return$code <- shiny::reactive({
exprs <- list()
+ last_n <- length(input$param_many)
- if (!is.null(input$param)) {
- if (input$param[[1]] > min(x(), na.rm = TRUE))
- exprs <- append(exprs, bquote(.x >= .(as.numeric(input$param[[1]]))))
- if (input$param[[2]] < max(x(), na.rm = TRUE))
- exprs <- append(exprs, bquote(.x <= .(as.numeric(input$param[[2]]))))
+ if (!is.null(input$param_many)) {
+ if (input$param_many[[1]] > min(x(), na.rm = TRUE))
+ exprs <- append(exprs, bquote(.x >= .(as.numeric(input$param_many[[1]]))))
+ if (input$param_many[[last_n]] < max(x(), na.rm = TRUE))
+ exprs <- append(exprs, bquote(.x <= .(as.numeric(input$param_many[[last_n]]))))
}
if (length(exprs) > 1) {
@@ -81,4 +100,4 @@ shiny_vector_filter_numeric_many <- function(input, output, session, x = shiny::
})
module_return
-}
\ No newline at end of file
+}
diff --git a/R/sysdata.rda b/R/sysdata.rda
new file mode 100644
index 0000000..150b810
Binary files /dev/null and b/R/sysdata.rda differ
diff --git a/R/utils.R b/R/utils.R
index 9bdeded..04a2c28 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -150,3 +150,12 @@ strip_leading_ws <- function(txt, simplify = TRUE) {
is.empty <- function(x) {
identical("", x)
}
+
+remove_shiny_inputs <- function(id, .input, ns = NS(NULL)) {
+ invisible(
+ lapply(grep(id, names(.input), value = TRUE), function(i) {
+ .subset2(.input, "impl")$.values$remove(ns(i))
+ })
+ )
+}
+
diff --git a/README.Rmd b/README.Rmd
index 7c24c26..34aeb65 100644
--- a/README.Rmd
+++ b/README.Rmd
@@ -7,7 +7,7 @@ output: "github_document"
Agnostic, Idiomatic Data Filter Module for Shiny.
-
+
@@ -45,17 +45,16 @@ devtools::install_github("Biogen-Inc/IDEAFilter")
After installation, you now have access to the`IDEAFilter` shiny module. On the UI side, you need only include the following line of code to place the filtering widget somewhere in your app:
```{r, eval=FALSE}
-shiny_data_filter_ui(inputId = "data_filter")
+IDEAFilter_ui(id = "data_filter")
```
-The server side logic needs to call the `shiny_data_filter` module, match the input ID from the UI, and provide a data source. The returned reactive data.frame (called "filtered_data") may used for downstream processes regardless on if the user chooses to apply filters or not.
+The server side logic needs to call the `IDEAFilter` module, match the input ID from the UI, and provide a data source. The returned reactive data.frame (called "filtered_data") may used for downstream processes regardless on if the user chooses to apply filters or not.
```{r, eval=FALSE}
filtered_data <- # name the returned reactive data frame
- callModule(
- shiny_data_filter, # call the module by name
+ IDEAFilter(
"data_filter", # give the filter a name(space)
- data = starwars2, # feed it raw data
+ data = starwars, # feed it raw data
verbose = FALSE
)
```
@@ -65,7 +64,7 @@ filtered_data <- # name the returned reactive data frame
Copy & paste the code below into a live R session to see the inner workings of the Star Wars app referenced above. Or click the button below to test drive the example app now!
-
+
@@ -98,18 +97,13 @@ ui <- fluidPage(
dataTableOutput("data_summary"),
h4("Generated Code"),
verbatimTextOutput("data_filter_code")),
- column(4, shiny_data_filter_ui("data_filter"))))
+ column(4, IDEAFilter_ui("data_filter"))))
server <- function(input, output, session) {
filtered_data <- # name the returned reactive data frame
- callModule(
- shiny_data_filter, # call the module
- "data_filter", # give the filter a name(space)
- data = starwars2, # feed it raw data
- verbose = FALSE
- )
+ IDEAFilter("data_filter", data = starwars2,verbose = FALSE)
# extract & display the "code" attribute to see dplyr::filter()
# statements performed
@@ -134,4 +128,4 @@ server <- function(input, output, session) {
}
shinyApp(ui = ui, server = server)
-```
\ No newline at end of file
+```
diff --git a/README.md b/README.md
index 87c8feb..aa71899 100644
--- a/README.md
+++ b/README.md
@@ -4,7 +4,7 @@
Agnostic, Idiomatic Data Filter Module for Shiny.
-
+
@@ -61,20 +61,19 @@ On the UI side, you need only include the following line of code to
place the filtering widget somewhere in your app:
``` r
-shiny_data_filter_ui(inputId = "data_filter")
+IDEAFilter_ui(id = "data_filter")
```
-The server side logic needs to call the `shiny_data_filter` module,
-match the input ID from the UI, and provide a data source. The returned
-reactive data.frame (called “filtered_data”) may used for downstream
-processes regardless on if the user chooses to apply filters or not.
+The server side logic needs to call the `IDEAFilter` module, match the
+input ID from the UI, and provide a data source. The returned reactive
+data.frame (called “filtered_data”) may used for downstream processes
+regardless on if the user chooses to apply filters or not.
``` r
filtered_data <- # name the returned reactive data frame
- callModule(
- shiny_data_filter, # call the module by name
+ IDEAFilter(
"data_filter", # give the filter a name(space)
- data = starwars2, # feed it raw data
+ data = starwars, # feed it raw data
verbose = FALSE
)
```
@@ -86,7 +85,7 @@ workings of the Star Wars app referenced above. Or click the button
below to test drive the example app now!
-
+
@@ -119,18 +118,13 @@ ui <- fluidPage(
dataTableOutput("data_summary"),
h4("Generated Code"),
verbatimTextOutput("data_filter_code")),
- column(4, shiny_data_filter_ui("data_filter"))))
+ column(4, IDEAFilter_ui("data_filter"))))
server <- function(input, output, session) {
filtered_data <- # name the returned reactive data frame
- callModule(
- shiny_data_filter, # call the module
- "data_filter", # give the filter a name(space)
- data = starwars2, # feed it raw data
- verbose = FALSE
- )
+ IDEAFilter("data_filter", data = starwars2,verbose = FALSE)
# extract & display the "code" attribute to see dplyr::filter()
# statements performed
diff --git a/cran-comments.md b/cran-comments.md
index f3d5371..4993df8 100644
--- a/cran-comments.md
+++ b/cran-comments.md
@@ -1,75 +1,33 @@
-## Re-submission 2022-06-27
-This is a re-submission. In this version I have:
+# CRAN v0.2.0 Re-submission
-* Referenced package names using single quotes in the description field. Also, spelled out 'UI' to 'user interface'.
+On April 10, 2024
-* Added appropriate `@return` roxygen comments for the following exported functions to generate `\value` statement in `.Rd` files:
- - getInitializationCode.shinyDataFilter_df.Rd
- - shiny_vector_filter_numeric_few.Rd
- - shiny_vector_filter_numeric_many.Rd
+### R CMD check results
+0 errors | 0 warnings | 0 note
-#### R CMD Check
-0 errors | 0 warnings | 1 note
-```
-checking CRAN incoming feasibility ... NOTE
- Maintainer: 'Aaron Clark '
-
- New submission
-```
-
-## Re-submission 2022-06-24
-This is a re-submission. In this version I have:
+### Reverse dependency check
-* Added more details about the package functionality in the Description field of the DESCRIPTION file.
+One reverse dependency exists (`{tidyCDISC}`) and was tested by running R CMD Check using the development version of `IDEAFilter`. The changes have no negative impact on it's reverse dependency.
-* Removed `@examples` section for unexported functions, which coincidentally also removed an instance where `:::` was used.
+
-* Used `if(interactive())` and not `\dontrun` in `man/shiny_data_filter.Rd`'s `@examples` section since it is insufficient by itself.
+# Initial CRAN v0.2.0 Submission
+On April 3, 2024
-#### R CMD Check
+### R CMD check results
0 errors | 0 warnings | 1 note
```
-checking CRAN incoming feasibility ... NOTE
- Maintainer: 'Aaron Clark '
-
- New submission
+Found the following (possibly) invalid URLs:
+ URL: https://bit.ly/demo_IDEAFilter (moved to https://rinpharma.shinyapps.io/IDEAfilter/)
+ From: README.md
+ Status: 301
+ Message: Moved Permanently
+ For content that is 'Moved Permanently', please change http to https,
+ add trailing slashes, or replace the old by the new URL.
```
+This is an intentional redirect that allows the package maintainer to monitor traffic to the demo application originating from the package README
+### Reverse dependency check
-## Re-submission 2022-06-11
-This is a re-submission. In this version I have:
-
-* Clearly identified the copyright holder in the DESCRIPTION file, and omitted the extra LICENSE file, per request, as it was not needed for AGPL-3.
-
-* Reduced the size of the package to be less than 5MB.
-
-#### R CMD Check
-0 errors | 0 warnings | 1 note
-```
-checking CRAN incoming feasibility ... NOTE
- Maintainer: 'Aaron Clark '
-
- New submission
-```
-## Initial submission 2022-06-10
-#### R CMD Check
-0 errors | 0 warnings | 1 note
-
-```
-checking CRAN incoming feasibility ... NOTE
- Maintainer: 'Aaron Clark '
-
- New submission
-
- License components with restrictions and base license permitting such:
- AGPL-3 + file LICENSE
- File 'LICENSE':
- YEAR: 2020
- COPYRIGHT HOLDER: Biogen;
-
- Size of tarball: 5464618 bytes
-```
-### Downstream dependencies
-
-There are none.
+One reverse dependency exists (`{tidyCDISC}`) and was tested by running R CMD Check using the development version of `IDEAFilter`. The changes have no negative impact on it's reverse dependency.
\ No newline at end of file
diff --git a/data-raw/internal-data.R b/data-raw/internal-data.R
new file mode 100644
index 0000000..f2ace27
--- /dev/null
+++ b/data-raw/internal-data.R
@@ -0,0 +1,17 @@
+## code to prepare `internal-data` dataset goes here
+set.seed(5000)
+vector_data <-
+ dplyr::tibble(
+ character = purrr::map_chr(1:50, ~ paste(sample(letters, 5, replace = TRUE), collapse = "")),
+ date = as.Date("2021-03-02") + floor(50*runif(50, min = -1)),
+ datetime = as.POSIXct("2021-02-02 11:54:56", format = "%Y-%m-%d %H:%M:%S") + floor((1:50*24*60*60 + runif(50, min = -1)*24*60*60)),
+ factor_few = as.factor(sample(LETTERS[1:4], 50, replace = TRUE)),
+ factor_many = as.factor(sample(LETTERS[1:10], 50, replace = TRUE)),
+ logical = runif(50, min = -1) > 0,
+ numeric_few = sample(1:5, 50, replace = TRUE),
+ numeric_many = floor(100*runif(50)),
+ unknown = purrr::map(1:50, ~ list(A = sample(letters, 5, replace = TRUE), B = sample(LETTERS, 5, replace = TRUE)))
+ )
+attr(vector_data$datetime, "tzone") <- "UTC"
+
+usethis::use_data(vector_data, overwrite = TRUE, internal = TRUE)
diff --git a/inst/WORDLIST b/inst/WORDLIST
index 267093f..952ca3c 100644
--- a/inst/WORDLIST
+++ b/inst/WORDLIST
@@ -1,5 +1,6 @@
Cheng
Pharma
+Pre
UI
df
dplyr
@@ -7,9 +8,11 @@ dropdown
getInitializationCode
ns
pharma
+pre
reactiveValues
readme
scriptgloss
+selectize
selectizeInput
shinyDataFilter
shinytest
diff --git a/inst/examples/iris_app/adsl.xpt b/inst/examples/iris_app/adsl.xpt
deleted file mode 100644
index 56e04ac..0000000
Binary files a/inst/examples/iris_app/adsl.xpt and /dev/null differ
diff --git a/inst/examples/iris_app/app.R b/inst/examples/iris_app/app.R
index b12fdbd..5bba523 100644
--- a/inst/examples/iris_app/app.R
+++ b/inst/examples/iris_app/app.R
@@ -12,15 +12,11 @@ ui <- fluidPage(
verbatimTextOutput("data_filter_code"),
dataTableOutput("data_summary")
),
- column(4, shiny_data_filter_ui("data_filter"))))
+ column(4, IDEAFilter_ui("data_filter"))))
server <- function(input, output, session) {
- filtered_data <- callModule(
- IDEAFilter::shiny_data_filter,
- "data_filter",
- data = iris,
- verbose = FALSE)
+ filtered_data <- IDEAFilter("data_filter", data = iris, verbose = FALSE)
output$data_filter_code <- renderPrint({
cat(gsub("%>%", "%>% \n ",
@@ -41,6 +37,4 @@ server <- function(input, output, session) {
}
-shinyApp(ui = ui, server = server)
-
-
+shinyApp(ui = ui, server = server)
\ No newline at end of file
diff --git a/inst/examples/starwars_app/app.R b/inst/examples/starwars_app/app.R
index 9d75234..c4afdcc 100644
--- a/inst/examples/starwars_app/app.R
+++ b/inst/examples/starwars_app/app.R
@@ -23,14 +23,39 @@ ui <- fluidPage(
dataTableOutput("data_summary"),
h4("Generated code:"),
verbatimTextOutput("data_filter_code")),
- column(4, shiny_data_filter_ui("data_filter"))))
+ column(4,
+ varSelectizeInput("col_subset", "Choose Column Subset", starwars2, multiple = TRUE),
+ div(
+ class = "form-group",
+ tags$label(class = "control-label", "Choose Pre-selection"),
+ div(
+ style = "display: flex",
+ actionButton("ex1", HTML("gender: feminine
height: >= 180cm"), width = "50%"),
+ actionButton("ex2", HTML("is_droid: TRUE; not NA
mass: < 50kg"), width = "50%")
+ )
+ ),
+ hr(),
+ br(),
+ IDEAFilter_ui("data_filter"))
+ ))
server <- function(input, output, session) {
- filtered_data <- callModule(
- shiny_data_filter,
- "data_filter",
- data = starwars2,
- verbose = FALSE)
+
+ preselection <- reactiveVal(NULL)
+ observeEvent(input$ex1, {
+ preselection(
+ list(gender = list(filter_fn = ~ .x == "feminine"),
+ height = list(filter_fn = ~ .x >= 180))
+ )
+ })
+ observeEvent(input$ex2, {
+ preselection(
+ list(is_droid = list(filter_na = TRUE, filter_fn = ~ isTRUE(.x)),
+ mass = list(filter_fn = ~ .x < 50))
+ )
+ })
+
+ filtered_data <- IDEAFilter("data_filter", data = starwars2, col_subset = reactive(input$col_subset), preselection = preselection, verbose = FALSE)
output$data_filter_code <- renderPrint({
cat(gsub("%>%", "%>% \n ",
diff --git a/man/IDEAFilter.Rd b/man/IDEAFilter.Rd
new file mode 100644
index 0000000..b27722e
--- /dev/null
+++ b/man/IDEAFilter.Rd
@@ -0,0 +1,94 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/IDEAFilter.R
+\name{IDEAFilter}
+\alias{IDEAFilter}
+\title{IDEA data filter module server function}
+\usage{
+IDEAFilter(
+ id,
+ data,
+ ...,
+ col_subset = NULL,
+ preselection = NULL,
+ verbose = FALSE
+)
+}
+\arguments{
+\item{id}{a module id name}
+
+\item{data}{a \code{data.frame} or \code{reactive expression} returning a
+\code{data.frame} to use as the input to the filter module}
+
+\item{...}{placeholder for inclusion of additional parameters in future development}
+
+\item{col_subset}{a \code{vector} containing the list of allowable columns to filter on}
+
+\item{preselection}{a \code{list} that can be used to pre-populate the filter}
+
+\item{verbose}{a \code{logical} value indicating whether or not to print log
+statements out to the console}
+}
+\value{
+a \code{reactive expression} which returns the filtered data wrapped
+ in an additional class, "shinyDataFilter_df". This structure also contains
+ a "code" field which represents the code needed to generate the filtered
+ data.
+}
+\description{
+Serves as a wrapper for \code{\link{shiny_data_filter}} and utilizes
+\code{moduleSever()} for a more modern implementation of the data item
+filter.
+}
+\examples{
+if(all(c(interactive(), require("dplyr"), require("IDEAFilter")))) {
+library(shiny)
+library(IDEAFilter)
+library(dplyr) # for data pre-processing and example data
+
+# prep a new data.frame with more diverse data types
+starwars2 <- starwars \%>\%
+ mutate_if(~is.numeric(.) && all(Filter(Negate(is.na), .) \%\% 1 == 0), as.integer) \%>\%
+ mutate_if(~is.character(.) && length(unique(.)) <= 25, as.factor) \%>\%
+ mutate(is_droid = species == "Droid") \%>\%
+ select(name, gender, height, mass, hair_color, eye_color, vehicles, is_droid)
+
+# create some labels to showcase column select input
+attr(starwars2$name, "label") <- "name of character"
+attr(starwars2$gender, "label") <- "gender of character"
+attr(starwars2$height, "label") <- "height of character in centimeters"
+attr(starwars2$mass, "label") <- "mass of character in kilograms"
+attr(starwars2$is_droid, "label") <- "whether character is a droid"
+
+ui <- fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8,
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, IDEAFilter_ui("data_filter"))))
+
+server <- function(input, output, session) {
+ filtered_data <- IDEAFilter("data_filter", data = starwars2, verbose = FALSE)
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("\%>\%", "\%>\% \n ",
+ gsub("\\\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+}
+
+shinyApp(ui = ui, server = server)
+}
+
+}
+\seealso{
+\link{IDEAFilter_ui}, \link{shiny_data_filter}
+}
diff --git a/man/IDEAFilter_item.Rd b/man/IDEAFilter_item.Rd
new file mode 100644
index 0000000..b406262
--- /dev/null
+++ b/man/IDEAFilter_item.Rd
@@ -0,0 +1,50 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/IDEAFilter_item.R
+\name{IDEAFilter_item}
+\alias{IDEAFilter_item}
+\title{The server function for the IDEA filter item module}
+\usage{
+IDEAFilter_item(
+ id,
+ data,
+ column_name = NULL,
+ filters = list(),
+ ...,
+ col_subset = NULL,
+ preselection = NULL,
+ verbose = FALSE
+)
+}
+\arguments{
+\item{id}{a module id name}
+
+\item{data}{a \code{reactive expression} returning a \code{data.frame} to use
+as the input to the filter item module}
+
+\item{column_name}{a value indicating the name of the column to be filtered}
+
+\item{filters}{a \code{reactive expression} containing the a list of filters
+passed as \code{language} types}
+
+\item{...}{placeholder for inclusion of additional parameters in future development}
+
+\item{col_subset}{a \code{vector} containing the list of allowable columns to filter on}
+
+\item{preselection}{a \code{list} that can be used to pre-populate the filter}
+
+\item{verbose}{a \code{logical} value indicating whether or not to print log
+statements out to the console}
+}
+\value{
+a \code{\link[shiny]{reactiveValues}} list of four reactive elements;
+ (1) the code to filter a vector with the name of the specified data column,
+ (2) a flag indicating when to remove this filter, (3) the append list of
+ combining the `filters` argument with (1), and (4) the column name of the
+ `data` used to create the item.
+}
+\description{
+Serves as a wrapper for \code{\link{shiny_data_filter_item}} and utilizes
+\code{moduleSever()} for a more modern implementation of the data item
+filter.
+}
+\keyword{internal}
diff --git a/man/IDEAFilter_item_ui.Rd b/man/IDEAFilter_item_ui.Rd
new file mode 100644
index 0000000..ab7f6fb
--- /dev/null
+++ b/man/IDEAFilter_item_ui.Rd
@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/IDEAFilter_item.R
+\name{IDEAFilter_item_ui}
+\alias{IDEAFilter_item_ui}
+\title{A single filter item as part of a IDEA filter module panel}
+\usage{
+IDEAFilter_item_ui(id)
+}
+\arguments{
+\item{id}{a module id name}
+}
+\value{
+a shiny \code{\link[shiny]{wellPanel}} to house the filter
+}
+\description{
+This is a wrapper for \code{\link{shiny_data_filter_item_ui}} created to
+match up with the module server function \code{\link{IDEAFilter_item}}.
+}
+\keyword{internal}
diff --git a/man/IDEAFilter_ui.Rd b/man/IDEAFilter_ui.Rd
new file mode 100644
index 0000000..d8a258f
--- /dev/null
+++ b/man/IDEAFilter_ui.Rd
@@ -0,0 +1,76 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/IDEAFilter.R
+\name{IDEAFilter_ui}
+\alias{IDEAFilter_ui}
+\title{User interface function to add a data filter panel}
+\usage{
+IDEAFilter_ui(id)
+}
+\arguments{
+\item{id}{a module id name}
+}
+\value{
+a shiny \code{\link[shiny]{tagList}} containing the filter ui
+}
+\description{
+This is a wrapper for \code{\link{shiny_data_filter_ui}} created to match up
+with the module server function \code{\link{IDEAFilter}}.
+}
+\examples{
+if(all(c(interactive(), require("dplyr"), require("IDEAFilter")))) {
+library(shiny)
+library(IDEAFilter)
+library(dplyr) # for data pre-processing and example data
+
+# prep a new data.frame with more diverse data types
+starwars2 <- starwars \%>\%
+ mutate_if(~is.numeric(.) && all(Filter(Negate(is.na), .) \%\% 1 == 0), as.integer) \%>\%
+ mutate_if(~is.character(.) && length(unique(.)) <= 25, as.factor) \%>\%
+ mutate(is_droid = species == "Droid") \%>\%
+ select(name, gender, height, mass, hair_color, eye_color, vehicles, is_droid)
+
+# create some labels to showcase column select input
+attr(starwars2$name, "label") <- "name of character"
+attr(starwars2$gender, "label") <- "gender of character"
+attr(starwars2$height, "label") <- "height of character in centimeters"
+attr(starwars2$mass, "label") <- "mass of character in kilograms"
+attr(starwars2$is_droid, "label") <- "whether character is a droid"
+
+ui <- fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8,
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, shiny_data_filter_ui("data_filter"))))
+
+server <- function(input, output, session) {
+ filtered_data <- callModule(
+ shiny_data_filter,
+ "data_filter",
+ data = starwars2,
+ verbose = FALSE)
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("\%>\%", "\%>\% \n ",
+ gsub("\\\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+}
+
+shinyApp(ui = ui, server = server)
+}
+
+}
+\seealso{
+\link{shiny_data_filter_ui}, \link{IDEAFilter}
+}
+\keyword{internal}
diff --git a/man/columnSelectInput.Rd b/man/columnSelectInput.Rd
index 284f41b..ca7124d 100644
--- a/man/columnSelectInput.Rd
+++ b/man/columnSelectInput.Rd
@@ -10,6 +10,7 @@ columnSelectInput(
data,
selected = "",
...,
+ col_subset = NULL,
placeholder = "",
onInitialize
)
@@ -25,6 +26,8 @@ columnSelectInput(
\item{...}{passed to \code{\link[shiny]{selectizeInput}}}
+\item{col_subset}{a \code{vector} containing the list of allowable columns to select}
+
\item{placeholder}{passed to \code{\link[shiny]{selectizeInput}} options}
\item{onInitialize}{passed to \code{\link[shiny]{selectizeInput}} options}
diff --git a/man/shiny_vector_filter_factor_few.Rd b/man/shiny_vector_filter_factor_few.Rd
index ee8bf29..b02ff0b 100644
--- a/man/shiny_vector_filter_factor_few.Rd
+++ b/man/shiny_vector_filter_factor_few.Rd
@@ -10,7 +10,9 @@ shiny_vector_filter_factor_few(
session,
x = shiny::reactive(factor()),
filter_na = shiny::reactive(TRUE),
- verbose = FALSE
+ filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)
)
}
\arguments{
@@ -28,6 +30,11 @@ session}
\item{filter_na}{a logical value indicating whether to filter \code{NA}
values from the \code{x} vector}
+\item{filter_fn}{A function to modify, specified in one of the following ways:
+* A named function, e.g. `mean`.
+* An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+* A formula, e.g. `~ .x + 1`.}
+
\item{verbose}{a \code{logical} value indicating whether or not to print log
statements out to the console}
}
diff --git a/man/shiny_vector_filter_factor_many.Rd b/man/shiny_vector_filter_factor_many.Rd
index 3f6fea8..952ad80 100644
--- a/man/shiny_vector_filter_factor_many.Rd
+++ b/man/shiny_vector_filter_factor_many.Rd
@@ -10,7 +10,9 @@ shiny_vector_filter_factor_many(
session,
x = shiny::reactive(factor()),
filter_na = shiny::reactive(FALSE),
- verbose = FALSE
+ filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)
)
}
\arguments{
@@ -28,6 +30,11 @@ session}
\item{filter_na}{a logical value indicating whether to filter \code{NA}
values from the \code{x} vector}
+\item{filter_fn}{A function to modify, specified in one of the following ways:
+* A named function, e.g. `mean`.
+* An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+* A formula, e.g. `~ .x + 1`.}
+
\item{verbose}{a \code{logical} value indicating whether or not to print log
statements out to the console}
}
diff --git a/man/shiny_vector_filter_numeric_few.Rd b/man/shiny_vector_filter_numeric_few.Rd
index c2ccfd3..6c11fd8 100644
--- a/man/shiny_vector_filter_numeric_few.Rd
+++ b/man/shiny_vector_filter_numeric_few.Rd
@@ -10,7 +10,9 @@ shiny_vector_filter_numeric_few(
session,
x = shiny::reactive(factor()),
filter_na = shiny::reactive(FALSE),
- verbose = FALSE
+ filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)
)
}
\arguments{
@@ -27,6 +29,11 @@ session}
\item{filter_na}{The \code{logical} TODO}
+\item{filter_fn}{A function to modify, specified in one of the following ways:
+* A named function, e.g. `mean`.
+* An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+* A formula, e.g. `~ .x + 1`.}
+
\item{verbose}{a \code{logical} value indicating whether or not to print log
statements out to the console}
}
diff --git a/man/shiny_vector_filter_numeric_many.Rd b/man/shiny_vector_filter_numeric_many.Rd
index 23fa394..8d8d169 100644
--- a/man/shiny_vector_filter_numeric_many.Rd
+++ b/man/shiny_vector_filter_numeric_many.Rd
@@ -10,7 +10,9 @@ shiny_vector_filter_numeric_many(
session,
x = shiny::reactive(numeric()),
filter_na = shiny::reactive(FALSE),
- verbose = FALSE
+ filter_fn = NULL,
+ verbose = FALSE,
+ erase_filters = shiny::reactive(0)
)
}
\arguments{
@@ -27,6 +29,11 @@ session}
\item{filter_na}{The \code{logical} TODO}
+\item{filter_fn}{A function to modify, specified in one of the following ways:
+* A named function, e.g. `mean`.
+* An anonymous function, e.g. `\(x) x + 1` or `function(x) x + 1`.
+* A formula, e.g. `~ .x + 1`.}
+
\item{verbose}{a \code{logical} value indicating whether or not to print log
statements out to the console}
}
diff --git a/tests/shinytest/shinytest_IDEAFilter/app.R b/tests/shinytest/shinytest_IDEAFilter/app.R
new file mode 100644
index 0000000..d38af83
--- /dev/null
+++ b/tests/shinytest/shinytest_IDEAFilter/app.R
@@ -0,0 +1,30 @@
+ui <- fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8,
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, IDEAFilter::IDEAFilter_ui("data_filter"))))
+
+srv <- function(input, output, session) {
+ filtered_data <- IDEAFilter::IDEAFilter(
+ "data_filter",
+ data = airquality,
+ verbose = FALSE)
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("%>%", "%>% \n ",
+ gsub("\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+}
+
+shinyApp(ui, srv)
diff --git a/tests/shinytest/shinytest_IDEAFilter_item/app.R b/tests/shinytest/shinytest_IDEAFilter_item/app.R
new file mode 100644
index 0000000..9434c83
--- /dev/null
+++ b/tests/shinytest/shinytest_IDEAFilter_item/app.R
@@ -0,0 +1,25 @@
+data <- mtcars
+data[which((data * 0.987) %% 0.2 < 0.01, arr.ind = TRUE)] <- NA
+
+ui <- fluidPage(
+ mainPanel(verbatimTextOutput("data_display")),
+ sidebarPanel(IDEAFilter::IDEAFilter_item_ui("filter")))
+
+srv <- function(input, output, session) {
+ filtered_data <- IDEAFilter::IDEAFilter_item(
+ "filter",
+ data = reactive(data))
+
+ filter_logical <- reactiveVal(TRUE)
+ observe({
+ filter_exprs <- filtered_data$filters()
+
+ filter_logical(if (!length(filter_exprs)) rep(TRUE,nrow(data)) else Reduce("&", Map(function(x) with(data, eval(x)), filter_exprs)))
+ })
+
+ output$data_display <- renderPrint({
+ print(IDEAFilter:::`%||%`(subset(data, filter_logical()), data.frame()))
+ })
+}
+
+shinyApp(ui, srv)
diff --git a/tests/shinytest/shinytest_data_types/app.R b/tests/shinytest/shinytest_data_types/app.R
new file mode 100644
index 0000000..83a3c9d
--- /dev/null
+++ b/tests/shinytest/shinytest_data_types/app.R
@@ -0,0 +1,30 @@
+ui <- fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8,
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, IDEAFilter_ui("data_filter"))))
+
+srv <- function(input, output, session) {
+ filtered_data <- IDEAFilter(
+ "data_filter",
+ data = vector_data,
+ verbose = FALSE)
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("%>%", "%>% \n ",
+ gsub("\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+}
+
+shinyApp(ui, srv)
\ No newline at end of file
diff --git a/tests/shinytest/shinytest_preselection/app.R b/tests/shinytest/shinytest_preselection/app.R
new file mode 100644
index 0000000..bed490f
--- /dev/null
+++ b/tests/shinytest/shinytest_preselection/app.R
@@ -0,0 +1,47 @@
+ui <- fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8,
+ selectInput("filter_select", NULL, choices = c("filter_1", "filter_2")),
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, IDEAFilter::IDEAFilter_ui("data_filter"))))
+
+srv <- function(input, output, session) {
+
+ preselection <- reactiveVal(list(Ozone = list(filter_na = TRUE, filter_fn = ~ .x >= 30),
+ Solar = list(filter_fn = ~ .x > 100),
+ Month = list(filter_fn = ~ .x == 9)))
+
+ observeEvent(input$filter_select, {
+ if (input$filter_select == "filter_1")
+ preselection(list(Ozone = list(filter_na = TRUE, filter_fn = ~ .x >= 30),
+ Solar = list(filter_fn = ~ .x > 100),
+ Month = list(filter_fn = ~ .x == 9)))
+ else
+ preselection(list(Ozone = list(filter_fn = ~ .x >= 30 & .x <= 90),
+ Wind = list(filter_fn = ~.x >= 5 & .x <= 10)))
+ })
+
+filtered_data <- IDEAFilter::IDEAFilter(
+ "data_filter",
+ data = airquality,
+ preselection = preselection,
+ verbose = FALSE)
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("%>%", "%>% \n ",
+ gsub("\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+}
+
+shinyApp(ui, srv)
diff --git a/tests/shinytest/shinytest_reactive_data/app.R b/tests/shinytest/shinytest_reactive_data/app.R
new file mode 100644
index 0000000..2517856
--- /dev/null
+++ b/tests/shinytest/shinytest_reactive_data/app.R
@@ -0,0 +1,46 @@
+mtcars2 <- mtcars
+mtcars2[which((mtcars2 * 0.987) %% 0.2 < 0.01, arr.ind = TRUE)] <- NA
+
+ui <- fluidPage(
+ fluidRow(
+ column(8,
+ selectInput("select_data", "Select Data", c("airquality", "mtcars"), selected = "airquality"),
+ verbatimTextOutput("data_summary"),
+ verbatimTextOutput("data_filter_code")),
+ column(4, IDEAFilter::IDEAFilter_ui("data_filter"))))
+
+srv <- function(input, output, session) {
+ data <- reactiveVal(airquality)
+ filtered_data <- IDEAFilter::IDEAFilter(
+ "data_filter",
+ data = data,
+ verbose = FALSE)
+
+ exportTestValues(
+ filtered_data = filtered_data()
+ )
+
+ observeEvent(input$select_data, {
+ if (input$select_data == "airquality")
+ data(airquality)
+ else
+ data(mtcars2)
+ })
+
+ output$data_filter_code <- renderPrint({
+ cat(gsub("%>%", "%>% \n ",
+ gsub("\\s{2,}", " ",
+ paste0(
+ capture.output(attr(filtered_data(), "code")),
+ collapse = " "))
+ ))
+ })
+
+ output$data_summary <- renderPrint({
+ if (nrow(filtered_data())) show(filtered_data())
+ else "No data available"
+ })
+
+}
+
+shinyApp(ui, srv)
diff --git a/tests/spelling.R b/tests/spelling.R
index 6713838..06a1204 100644
--- a/tests/spelling.R
+++ b/tests/spelling.R
@@ -1,3 +1,5 @@
if(requireNamespace('spelling', quietly = TRUE))
spelling::spell_check_test(vignettes = TRUE, error = FALSE,
skip_on_cran = TRUE)
+# spelling::spell_check_package()
+# spelling::update_wordlist()
\ No newline at end of file
diff --git a/tests/testthat/test_IDEAFilter.R b/tests/testthat/test_IDEAFilter.R
new file mode 100644
index 0000000..e36f126
--- /dev/null
+++ b/tests/testthat/test_IDEAFilter.R
@@ -0,0 +1,53 @@
+context("test_IDEAFilter")
+skip_on_cran()
+
+app_path <- IDEAFilter:::shinytest_path("shinytest_IDEAFilter")
+app <- shinytest2::AppDriver$new(app_path)
+
+app$set_inputs(`data_filter-add_filter_select` = "Wind")
+app$wait_for_js('document.getElementById("data_filter-filter_1-remove_filter_btn")')
+app$set_inputs(`data_filter-filter_1-remove_filter_btn` = "click")
+
+test_that("test that a new filter item has been added", {
+ expect_true(!"data_filter-filter_1-column_select" %in% lapply(app$get_values(), names)$input)
+})
+
+
+
+app$set_inputs(`data_filter-add_filter_select` = "Ozone")
+app$wait_for_js('document.getElementById("data_filter-filter_2-vector_filter-param_many")')
+app$set_inputs(`data_filter-filter_2-vector_filter-param_many` = c(30, 90))
+
+test_that("test that a new filter item has been added", {
+ expect_equal(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality, is.na(Ozone) | (Ozone >= 30 & Ozone <= 90)))())
+})
+
+
+
+app$set_inputs(`data_filter-filter_2-filter_na_btn` = "click")
+
+test_that("test that a new filter item has been added", {
+ expect_equal(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality, Ozone >= 30 & Ozone <= 90))())
+})
+
+
+
+
+app$set_inputs(`data_filter-add_filter_select` = "Wind")
+app$wait_for_js('document.getElementById("data_filter-filter_3-vector_filter-param_many")')
+app$set_inputs(`data_filter-filter_3-vector_filter-param_many` = c(5, 10))
+
+test_that("test that nrow reactive value is accurate", {
+ expect_equal(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality,
+ (Ozone >= 30 & Ozone <= 90) &
+ (is.na(Wind) | (Wind >= 5 & Wind <= 10))
+ ))())
+})
+
+app$stop()
diff --git a/tests/testthat/test_IDEAFilter_item.R b/tests/testthat/test_IDEAFilter_item.R
new file mode 100644
index 0000000..e1e6a4e
--- /dev/null
+++ b/tests/testthat/test_IDEAFilter_item.R
@@ -0,0 +1,49 @@
+context("test_IDEAFilter_item")
+skip_on_cran()
+
+# reflects data used in shinytest
+data <- mtcars
+data[which((data * 0.987) %% 0.2 < 0.01, arr.ind = TRUE)] <- NA
+
+app_path <- IDEAFilter:::shinytest_path("shinytest_IDEAFilter_item")
+app <- shinytest2::AppDriver$new(app_path)
+
+
+test_that("test that filter item initializes with column select", {
+ expect_true(!"filter-vector_filter-param" %in% lapply(app$get_values(), names))
+})
+
+
+
+app$set_inputs(`filter-column_select` = "mpg")
+app$wait_for_js('document.getElementById("filter-vector_filter-param_many")')
+app$set_inputs(`filter-vector_filter-param_many` = c(20, 25))
+
+
+
+test_that("test that nrow reactive value is accurate", {
+ expect_equal(
+ app$get_value(output = "filter-nrow"),
+ as.character(nrow(subset(data, is.na(mpg) | (mpg >= 20 & mpg <= 25)))))
+})
+
+
+
+app$set_inputs(`filter-filter_na_btn` = "click")
+
+test_that("test that filtering NAs works", {
+ expect_equal(
+ app$get_value(output = "filter-nrow"),
+ as.character(nrow(subset(data, mpg >= 20 & mpg <= 25))))
+})
+
+
+
+app$set_inputs(`filter-column_select_edit_btn` = "click")
+
+test_that("test editing column removes vector filter", {
+ expect_true(!"filter-vector_filter-param" %in% lapply(app$get_values(), names))
+})
+
+
+app$stop()
diff --git a/tests/testthat/test_preselection.R b/tests/testthat/test_preselection.R
new file mode 100644
index 0000000..2eca1ab
--- /dev/null
+++ b/tests/testthat/test_preselection.R
@@ -0,0 +1,31 @@
+context("test_preselection")
+skip_on_cran()
+
+app_path <- IDEAFilter:::shinytest_path("shinytest_preselection")
+app <- shinytest2::AppDriver$new(app_path)
+
+app$wait_for_idle()
+
+test_that("test that a new filter item has been added", {
+ expect_true(!"data_filter-filter_2-column_select" %in% lapply(app$get_values(), names)$input)
+})
+
+test_that("test that a new filter item has been added", {
+ expect_equal(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality, Ozone >= 30 & Month == 9))())
+})
+
+app$set_inputs(filter_select = "filter_2")
+app$wait_for_idle()
+
+test_that("test that nrow reactive value is accurate", {
+ expect_equal(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality,
+ (is.na(Ozone) | (Ozone >= 30 & Ozone <= 90)) &
+ (is.na(Wind) | (Wind >= 5 & Wind <= 10))
+ ))())
+})
+
+app$stop()
diff --git a/tests/testthat/test_reactive_data.R b/tests/testthat/test_reactive_data.R
new file mode 100644
index 0000000..5bdc2e4
--- /dev/null
+++ b/tests/testthat/test_reactive_data.R
@@ -0,0 +1,47 @@
+context("test_reactive_data")
+skip_on_cran()
+
+# reflects data used in shinytest
+mtcars2 <- mtcars
+mtcars2[which((mtcars2 * 0.987) %% 0.2 < 0.01, arr.ind = TRUE)] <- NA
+
+app_path <- IDEAFilter:::shinytest_path("shinytest_reactive_data")
+app <- shinytest2::AppDriver$new(app_path)
+
+app$set_inputs(`data_filter-add_filter_select` = "Ozone")
+app$wait_for_js('document.getElementById("data_filter-filter_1-remove_filter_btn")')
+app$wait_for_idle()
+app$set_inputs(`data_filter-filter_1-vector_filter-param_many` = c(30, 90))
+
+test_that("test that a new filter item has been added", {
+ expect_equivalent(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality, is.na(Ozone) | (Ozone >= 30 & Ozone <= 90)))())
+})
+
+app$set_inputs(select_data = "mtcars")
+
+test_that("test that a new filter item has been added", {
+ expect_equivalent(
+ app$get_value(output = "data_summary"),
+ renderPrint(mtcars2)())
+})
+
+app$set_inputs(`data_filter-add_filter_select` = "mpg")
+app$wait_for_js('document.getElementById("data_filter-filter_2-remove_filter_btn")')
+app$wait_for_idle()
+app$set_inputs(`data_filter-filter_2-vector_filter-param_many` = c(20, 25))
+
+test_that("test that a new filter item has been added", {
+ expect_equivalent(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(mtcars2, is.na(mpg) | (mpg >= 20 & mpg <= 25)))())
+})
+
+app$set_inputs(select_data = "airquality")
+
+test_that("test that a new filter item has been added", {
+ expect_equivalent(
+ app$get_value(output = "data_summary"),
+ renderPrint(subset(airquality, is.na(Ozone) | (Ozone >= 30 & Ozone <= 90)))())
+})
diff --git a/tests/testthat/test_shiny_data_filter.R b/tests/testthat/test_shiny_data_filter.R
index 1c489e6..1add023 100644
--- a/tests/testthat/test_shiny_data_filter.R
+++ b/tests/testthat/test_shiny_data_filter.R
@@ -15,8 +15,8 @@ test_that("test that a new filter item has been added", {
app$set_inputs(`data_filter-add_filter_select` = "Ozone")
-app$wait_for_js('document.getElementById("data_filter-filter_2-vector_filter-param")')
-app$set_inputs(`data_filter-filter_2-vector_filter-param` = c(30, 90))
+app$wait_for_js('document.getElementById("data_filter-filter_2-vector_filter-param_many")')
+app$set_inputs(`data_filter-filter_2-vector_filter-param_many` = c(30, 90))
test_that("test that a new filter item has been added", {
expect_equal(
@@ -38,8 +38,8 @@ test_that("test that a new filter item has been added", {
app$set_inputs(`data_filter-add_filter_select` = "Wind")
-app$wait_for_js('document.getElementById("data_filter-filter_3-vector_filter-param")')
-app$set_inputs(`data_filter-filter_3-vector_filter-param` = c(5, 10))
+app$wait_for_js('document.getElementById("data_filter-filter_3-vector_filter-param_many")')
+app$set_inputs(`data_filter-filter_3-vector_filter-param_many` = c(5, 10))
test_that("test that nrow reactive value is accurate", {
expect_equal(
diff --git a/tests/testthat/test_shiny_data_filter_item.R b/tests/testthat/test_shiny_data_filter_item.R
index b462d24..b26787e 100644
--- a/tests/testthat/test_shiny_data_filter_item.R
+++ b/tests/testthat/test_shiny_data_filter_item.R
@@ -16,8 +16,8 @@ test_that("test that filter item initializes with column select", {
app$set_inputs(`filter-column_select` = "mpg")
-app$wait_for_js('document.getElementById("filter-vector_filter-param")')
-app$set_inputs(`filter-vector_filter-param` = c(20, 25))
+app$wait_for_js('document.getElementById("filter-vector_filter-param_many")')
+app$set_inputs(`filter-vector_filter-param_many` = c(20, 25))
diff --git a/tests/testthat/test_shiny_vector_filter_numeric.R b/tests/testthat/test_shiny_vector_filter_numeric.R
index 1394612..3428d32 100644
--- a/tests/testthat/test_shiny_vector_filter_numeric.R
+++ b/tests/testthat/test_shiny_vector_filter_numeric.R
@@ -6,11 +6,11 @@ app <- shinytest2::AppDriver$new(app_path)
data <- c(1:9, NA)
app$set_inputs(`data_dput` = paste(capture.output(dput(data)), paste = "\n"))
-app$wait_for_js('document.getElementById("test_in-param")')
+app$wait_for_js('document.getElementById("test_in-param_many")')
test_that("testing that numeric vectors get filtered properly", {
- app$set_inputs(`test_in-param` = c(3, 6))
+ app$set_inputs(`test_in-param_many` = c(3, 6))
app$set_inputs(`filter_na` = TRUE)
expect_equal(
@@ -33,7 +33,7 @@ test_that("testing that numeric vectors get filtered properly", {
test_that("testing that numeric vector filter code builds properly", {
- app$set_inputs(`test_in-param` = c(5, 8))
+ app$set_inputs(`test_in-param_many` = c(5, 8))
app$set_inputs(`filter_na` = TRUE)
expect_equal(
diff --git a/vignettes/.gitignore b/vignettes/.gitignore
new file mode 100644
index 0000000..097b241
--- /dev/null
+++ b/vignettes/.gitignore
@@ -0,0 +1,2 @@
+*.html
+*.R
diff --git a/vignettes/IDEAFilter.Rmd b/vignettes/IDEAFilter.Rmd
new file mode 100644
index 0000000..4a6fd9f
--- /dev/null
+++ b/vignettes/IDEAFilter.Rmd
@@ -0,0 +1,80 @@
+---
+title: "Using IDEAFilter"
+output: rmarkdown::html_vignette
+vignette: >
+ %\VignetteIndexEntry{Using IDEAFilter}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+ collapse = TRUE,
+ comment = "#>"
+)
+```
+
+# Minimal Example
+
+Here is a minimal example using `IDEAFilter_ui()` and `IDEAFilter()` to explore a data set:
+
+```{r, eval=FALSE}
+library(shiny)
+library(IDEAFilter)
+library(dplyr)
+shinyApp(
+ ui = fluidPage(
+ titlePanel("Filter Data Example"),
+ fluidRow(
+ column(8, dataTableOutput("data_summary")),
+ column(4, IDEAFilter_ui("data_filter")))),
+ server = function(input, output, session) {
+ filtered_data <- IDEAFilter("data_filter", data = iris, verbose = FALSE)
+ output$data_summary <-
+ renderDataTable(filtered_data(),
+ options = list(scrollX = TRUE, pageLength = 5))
+ }
+)
+```
+
+The server side of the module returns the reactive `ShinyDataFilter_df` object which includes the filtered data frame and the code used to filter it as an attribute.
+
+# A Larger Example
+
+With the release of `IDEAFilter()` to replace the deprecated `shiny_data_filter()`, a couple more arguments have been introduced to enhance the functionality of the filter.
+
+- Column Sub-setting: restricting the columns a user can add to the filter.
+- Pre-selection: pre-specifying a collection of filters to either pre-load in the filter or for users to dynamically apply.
+
+To explore these features we can run the following example application:
+
+```{r, eval=FALSE}
+library(shiny)
+library(IDEAFilter)
+app <- system.file("examples", "starwars_app", package = "IDEAFilter")
+runApp(app)
+```
+
+## Column Sub-setting
+
+In the application you can freely select a subset of columns to include in the filter. The `col_subset` argument can be set in development of an application or can be a reactive variable in deployment. You should note these columns can still be set using pre-selection and will still be applied to the filter. For instance, you can see below that only `height` has been selected but `gender` is still being applied.
+
+{style="position:center; width:100%"}
+
+## Pre-selection
+
+The application comes with two choices to apply pre-selection:
+
+- Gender listed as feminine and height greater than 180 cm
+- Character is a droid (excluding `NA`s) and has a mass less than 50 kg
+
+Looking at the second example is informative on how a developer can create their own pre-selections.
+
+```{r, eval=FALSE}
+list(
+ is_droid = list(filter_na = TRUE, filter_fn = ~ isTRUE(.x)),
+ mass = list(filter_fn = ~ .x < 50))
+)
+```
+
+The argument `preselection` is a named list where the names correspond to column names in the data set and the elements are lists containing the elements `filter_na` and `filter_fn`. The missing values (i.e. NAs) will be filtered if `filter_na` is set to `TRUE`. The `filter_fn` element can either be a formula or a function. The filter will attempt to apply the function to the data set when populating the initial values.
diff --git a/vignettes/images/colsubset.png b/vignettes/images/colsubset.png
new file mode 100644
index 0000000..ecf1a89
Binary files /dev/null and b/vignettes/images/colsubset.png differ