Initial commit

.Rbuildignore

@@ -0,0 +1,9 @@
+^.*\.Rproj$
+^\.Rproj\.user$
+^LICENSE\.md$
+^LICENSE$
+^_pkgdown\.yml$
+^docs$
+^\.github
+^\.lintr$
+^NEWS\.md$

.gitignore

@@ -0,0 +1,8 @@
+.Rproj.user
+.Rhistory
+.RData
+.Ruserdata
+.vscode
+docs/
+vignettes/*.html
+vignettes/*.R

DESCRIPTION

@@ -0,0 +1,39 @@
+Type: Package
+Package: dv.filter
+Title: Dynamic Data Filtering Module
+Version: 2.1.1
+Authors@R: c(
+        person("Boehringer-Ingelheim Pharma GmbH & Co.KG", role = c("cph", "fnd")),
+        person("Ming", "Yang", email = "[email protected]", role = c("aut", "cre")),
+        person("Sorin", "Voicu", email = "[email protected]", role = "aut")
+    )
+Description: Provides functionality to filter data frame dynamically.
+    It is common to use 'dv.filter' together with 'dv.manager' for building
+    interactive web applications through a modular framework.
+License: Apache License 2.0
+URL: https://github.com/Boehringer-Ingelheim/dv.filter
+BugReports: https://github.com/Boehringer-Ingelheim/dv.filter/issues
+Depends: R (>= 4.0)
+Imports:
+    dplyr (>= 1.0.5),
+    ggplot2 (>= 3.3.3),
+    glue (>= 1.4.2),
+    magrittr (>= 2.0.1),
+    purrr (>= 0.3.4),
+    rlang (>= 0.4.11),
+    shiny (>= 1.6.0),
+    shinyWidgets (>= 0.6.0)
+Suggests:
+    knitr (>= 1.33),
+    pharmaverseadam (>= 0.2.0),
+    rmarkdown (>= 2.7),
+    rvest (>= 1.0.0),
+    shinytest2 (>= 0.3.1),
+    testthat (>= 3.0.2)
+VignetteBuilder: knitr
+Config/testthat/edition: 3
+Encoding: UTF-8
+Language: en-US
+LazyData: true
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.0

LICENSE

@@ -0,0 +1,13 @@
+Copyright 2024 Boehringer-Ingelheim Pharma GmbH & Co.KG
+
+Licensed under the Apache License, Version 2.0 (the "License");
+you may not use this file except in compliance with the License.
+You may obtain a copy of the License at
+
+    http://www.apache.org/licenses/LICENSE-2.0
+
+Unless required by applicable law or agreed to in writing, software
+distributed under the License is distributed on an "AS IS" BASIS,
+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+See the License for the specific language governing permissions and
+limitations under the License.

NAMESPACE

@@ -0,0 +1,7 @@
+# Generated by roxygen2: do not edit by hand
+
+export(data_filter_server)
+export(data_filter_ui)
+importFrom(magrittr,"%>%")
+importFrom(rlang,"%||%")
+importFrom(rlang,.data)

NEWS.md

@@ -0,0 +1,21 @@
+# dv.filter 2.1.1
+
+- Initial release to GitHub
+
+# dv.filter 2.1.0
+
+- Fix bug when selecting categorical filter with a single value
+
+- Use 'shinytest2' for testing Shiny apps
+
+# dv.filter 2.0.0
+
+- Add barplots for categorical filters
+
+# dv.filter 1.0.0
+
+- First productive release to the BI Nexus package manager
+
+- Primary interface: `data_filter_ui()` and `data_filter_server()`
+
+- Enables bookmarking state of Shiny app via URL

R/create_filter_expr.R

@@ -0,0 +1,31 @@
+#' Create filter expression for a single filter
+#' @param x a numeric/character vector
+#' @param var name of a filter variable
+#' @param val values from input controls (range slider / drop-down menu)
+#' @param include_na a logical value indicating whether missing values (NA)
+#' should be included
+create_filter_expr <- function(x, var, val, include_na = TRUE) {
+  var_ <- as.name(var)
+  if (get_input_type(x) == "slider") {
+    expr <- rlang::expr(!!var_ >= !!val[1] & !!var_ <= !!val[2])
+    if (include_na) {
+      expr <- rlang::expr(is.na(!!var_) | !!expr)
+    } else {
+      expr <- rlang::expr(!is.na(!!var_) & !!expr)
+    }
+  } else if (get_input_type(x) == "picker") {
+    # similar to factor/character, logical values are treated as categorical
+    # ("TRUE"/"FALSE") in pickerInput. however, logical values (TRUE/FALSE) in
+    # original and filtered datasets are not changed. thus, filter expression
+    # for logical values should be treated differently
+    val2 <- val
+    if (get_first_class(x) == "logical") {
+      val2 <- as.logical(val)
+    }
+    val2 <- ifelse(val2 == "<MISSING>", NA, val2)
+    expr <- rlang::expr(!!var_ %in% !!val2)
+  } else {
+    expr <- rlang::expr(TRUE)
+  }
+  expr
+}

R/create_filter_ui.R

@@ -0,0 +1,79 @@
+#' Create filter UI for a single filter
+#' @param x a numeric/character vector
+#' @param id namespaced variable id
+#' @param var name of a filter variable
+#' @param val values from input controls (range slider / drop-down menu)
+#' @return UI element for a numeric or categorical filter
+create_filter_ui <- function(x, id, var, val) {
+  # https://github.com/rstudio/shiny/issues/2111
+  na_sum <- sum(is.na(x))
+  var_ui <- shiny::tags$strong(var)
+  remove_ui <- shiny::actionLink(
+    inputId = paste0(id, "_remove"),
+    label = NULL,
+    icon = shiny::icon("times-circle"),
+    style = "float: right; color: #8a1501;"
+  )
+  if (get_input_type(x) == "slider") {
+    rng <- range_slider(x)
+    # https://github.com/rstudio/shiny/issues/1409
+    plot_ui <- shiny::div(
+      style = "margin: 0px 10px -25px 10px;",
+      shiny::plotOutput(paste0(id, "_plot"), height = 25)
+    )
+    slider_ui <- shiny::sliderInput(
+      inputId = id,
+      label = NULL,
+      min = rng[1],
+      max = rng[2],
+      value = val %||% rng
+    )
+    na_sum_ui <- if (na_sum > 0) {
+      shiny::tags$small(
+        shinyWidgets::prettyCheckbox(
+          inputId = paste0(id, "_na"),
+          label = "Include missing values",
+          value = TRUE,
+          icon = shiny::icon("check"),
+          inline = FALSE
+        )
+      )
+    }
+    filter_ui <- shiny::div(var_ui, remove_ui, na_sum_ui, plot_ui, slider_ui)
+  } else if (get_input_type(x) == "picker") {
+    tbl_sorted <- sort(table(x), decreasing = TRUE)
+    N <- c("<MISSING>" = na_sum, tbl_sorted) # nolint
+    N <- N[N > 0] # nolint
+    choices <- names(N)
+    N_pct <- floor(100 * N / max(N)) # nolint
+    color <- rep("#000000", length(N)) # "black"
+    if (na_sum > 0) color[1] <- "#8B0000" # "darkred"
+    # https://blog.prototypr.io/css-only-multi-color-backgrounds-4d96a5569a20?gi=ae55142ef933
+    style <- glue::glue(
+      "color: {color}; border: 1px solid black; background: 
+       linear-gradient(90deg, rgba(173, 216, 230, 1) {N_pct}%, rgba(0, 0, 0, 0) {N_pct}%);"
+    )
+    picker_ui <- shinyWidgets::pickerInput(
+      inputId = id,
+      label = NULL,
+      multiple = TRUE,
+      choices = choices,
+      selected = val %||% choices,
+      choicesOpt = list(
+        style = style,
+        subtext = N
+      ),
+      options = shinyWidgets::pickerOptions(
+        actionsBox = TRUE,
+        liveSearch = TRUE
+      )
+    )
+    filter_ui <- shiny::div(var_ui, remove_ui, picker_ui)
+  } else {
+    msg <- paste0("Filter for `", get_first_class(x), "` is not supported")
+    br_ui <- shiny::tags$br()
+    control_ui <- shiny::tags$small(br_ui, msg, br_ui, br_ui)
+    filter_ui <- shiny::div(var_ui, control_ui)
+  }
+  filter_ui
+}