` controling the number of filters to apply. Besides, at the moment, our implementation of the filter block exposes additive operations, meaning that the result corresponds to `cond1 && cond2 && ...`.
+
+```{r, echo=FALSE}
+mermaid(
+ "flowchart TD
+ filt_data_in[Data input]
+ filt_data_out[Transformed data]
+ subgraph filt_block[Filter block]
+ filt_select_col[Select columns]
+ filt_filter_func[Filter function ==, !=]
+ filt_filter_val[Filter values]
+ filt_expr[Expression]
+ filt_res[Result]
+
+ filt_select_col --> filt_expr
+ filt_select_col --> |depends| filt_filter_val
+ filt_filter_val --> filt_expr
+ filt_filter_func --> filt_expr
+
+ filt_expr --> filt_res
+ end
+ filt_data_in --> filt_block --> filt_data_out
+ ",
+ height = "700px"
+) |>
+ htmlwidgets::onRender(
+ "function(el, x) {
+ el.classList.add('text-center')
+ }
+ "
+ )
+```
+
+
### The user interface
By default, only the last __stack__ block is visible, all others are collapsed.
@@ -241,3 +324,36 @@ server <- function(input, output, session) {
shinyApp(ui, server)
```
+
+### Connect stacks: the workspace
+
+The __workspace__ allows you to create more complex analysis by connecting stacks together and get a dashboard.
+To know more about this you can read the following [article](https://blockr-org.github.io/blockr/articles/data-blocks.html#reading-data-from-another-stack).
+
+```{r, echo=FALSE}
+mermaid(
+ "flowchart TD
+ subgraph s1[Stack 1]
+ direction TB
+ input_s1(Data)
+ transform_s1(Transform)
+ input_s1 --> |data| transform_s1
+ end
+ transform_s1 --> |data| input_s2
+ subgraph s2[Stack 2]
+ direction TB
+ input_s2(Data)
+ transform_s2(Transform)
+ output_s2(Visualize)
+ input_s2 --> |data| transform_s2 --> |data| output_s2
+ end
+ ",
+ height = "600px"
+) |>
+ htmlwidgets::onRender(
+ "function(el, x) {
+ el.classList.add('text-center')
+ }
+ "
+ )
+```
diff --git a/vignettes/blockr_examples.Rmd b/vignettes/blockr_examples.Rmd
new file mode 100644
index 00000000..8784c459
--- /dev/null
+++ b/vignettes/blockr_examples.Rmd
@@ -0,0 +1,820 @@
+---
+title: "Case studies"
+output: rmarkdown::html_vignette
+vignette: >
+ %\VignetteIndexEntry{Case studies}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r setup, include=FALSE}
+library(blockr)
+library(bslib)
+knitr::opts_chunk$set(echo = TRUE)
+```
+
+## blockr Across Industries
+
+The flexibility of `blockr` makes it valuable across various industries. Let's explore how it can be applied in different sectors with detailed examples. Somex examples require to create a new field such as the `new_slider_field` described in the corresponding vignette.
+
+```{r slider_block, include=FALSE}
+# Provided by John, new_range_field not working
+new_slider_field <- function(value = 5L, min = 0L, max = 10L, step = 1L, ...) {
+ blockr::new_field(
+ value = value,
+ min = min,
+ max = max,
+ step = step,
+ ...,
+ class = "slider_field"
+ )
+}
+
+#' @method ui_input slider_field
+#' @export
+ui_input.slider_field <- function(x, id, name) {
+ shiny::sliderInput(
+ blockr:::input_ids(x, id),
+ name,
+ value = blockr::value(x, "value"),
+ min = blockr::value(x, "min"),
+ max = blockr::value(x, "max"),
+ step = blockr::value(x, "step")
+ )
+}
+
+#' @method validate_field slider_field
+#' @export
+validate_field.slider_field <- function(x) {
+ x
+}
+
+#' @method ui_update slider_field
+#' @export
+ui_update.slider_field <- function(x, session, id, name) {
+ updateSliderInput(
+ session,
+ blockr::input_ids(x, id),
+ blockr::get_field_name(x, name),
+ blockr::value(x),
+ blockr::value(x, "min"),
+ blockr::value(x, "max")
+ )
+}
+```
+
+```{r filter_block, include=FALSE}
+#' Correlation plot
+#' @param data dataset.
+#' @param ... ignored.
+#' @export
+filter_in_block <- function(data, ...) {
+ sub_fields <- \(data, column) {
+ if (!length(column)) {
+ column <- names(data)[1]
+ }
+
+ list(
+ values = blockr::select_field(data[[column]][1], unique(data[[column]]), multiple = TRUE)
+ )
+ }
+
+ fields <- list(
+ column = blockr::new_select_field(
+ \(data) names(data)[1],
+ choices = \(data) names(data),
+ title = "Column"
+ ),
+ values = blockr::new_list_field(character(), sub_fields)
+ )
+
+ blockr::new_block(
+ fields = fields,
+ expr = quote({
+ vals <- unname(.(values))
+ data |>
+ dplyr::filter(!!dplyr::sym(.(column)) %in% vals[[1]])
+ }),
+ ...,
+ class = c("filter_in_block", "transform_block", "submit_block")
+ )
+}
+
+blockr::register_block(
+ constructor = filter_in_block,
+ name = "Filter in",
+ description = "Filter on a vector",
+ classes = c("filter_in_block", "transform_block"),
+ input = "data.frame",
+ output = "data.frame"
+)
+```
+
+
+### 1. Finance: Stock Price Forecasting
+
+In this example, we'll create a pipeline that fetches recent stock data using the [quantmod package](https://github.com/joshuaulrich/quantmod), performs time series analysis, and forecasts future stock prices using the [Prophet model](https://github.com/facebook/prophet). We first design the `stock_data_block`, containing a field to select the stock items and generate the data. The `prophet_forecast_block` does all the modeling part.
+
+```{r stock_example, eval=FALSE}
+# Does not run on shinylive as quantmod/prophet not available
+library(blockr)
+library(quantmod)
+library(prophet)
+
+# Custom block to fetch stock data
+new_stock_data_block <- function(...) {
+ # stocks to pick (top 10)
+ pick_stock <- \() c("NVDA", "TSLA", "AAPL", "MSFT", "AVGO", "AMZN", "AMD", "PLTR", "TSM", "META")
+
+
+ new_block(
+ fields = list(
+ ticker = new_select_field(pick_stock()[1], pick_stock, multiple = FALSE, title = "Ticker")
+ ),
+ expr = quote({
+ data_xts <- getSymbols(.(ticker), src = "yahoo", auto.assign = FALSE)
+ data.frame(Date = index(data_xts), coredata(data_xts)) |>
+ tail(700) # only considering last 700 days for this example
+ }),
+ class = c("stock_data_block", "data_block"),
+ ...
+ )
+}
+
+# Custom block for Prophet forecasting
+new_prophet_forecast_block <- function(columns = character(), ...) {
+ all_cols <- function(data) colnames(data)[2:length(colnames(data))]
+
+
+ new_block(
+ fields = list(
+ # date_col = new_select_field(columns, all_cols, multiple=FALSE, title="Date"),
+ value_col = new_select_field(columns, all_cols, multiple = FALSE, title = "Value"),
+ periods = new_slider_field(7, min = 0, max = 365, title = "Forecast duration")
+ ),
+ expr = quote({
+ df <- data.frame(
+ ds = data$Date,
+ y = data[[.(value_col)]]
+ )
+ model <- prophet(df)
+ future <- make_future_dataframe(model, periods = .(periods))
+ forecast <- predict(model, future)
+ plot(model, forecast)
+ }),
+ class = c("prophet_forecast_block", "plot_block"),
+ ...
+ )
+}
+
+# Register custom blocks
+register_block(
+ new_stock_data_block,
+ name = "Stock Data",
+ description = "Fetch stock data",
+ classes = c("stock_data_block", "data_block"),
+ input = NA_character_,
+ output = "data.frame"
+)
+register_block(
+ new_prophet_forecast_block,
+ name = "Prophet Forecast",
+ description = "Forecast using Prophet",
+ classes = c("prophet_forecast_block", "plot_block"),
+ input = "data.frame",
+ output = "plot"
+)
+
+# Create the stack
+stock_forecast_stack <- new_stack(
+ new_stock_data_block(),
+ new_prophet_forecast_block()
+)
+
+serve_stack(stock_forecast_stack)
+```
+
+```{r blockr-stock, echo=FALSE, fig.cap='Stock model demo', fig.align = 'center', out.width='100%'}
+knitr::include_graphics("figures/blockr-stock-demo.png")
+```
+
+### 2. Pharmaceutical: Clinical Trial Analysis
+
+#### 2.1 AE Forest Plot
+
+This forest plot visualizes the relative risk of adverse events between two treatment arms in a clinical trial. In this case, it compares "Xanomeline High Dose" to "Xanomeline Low Dose" starting from the [pharmaverseadam](https://github.com/pharmaverse/pharmaverseadam) `adae` dataset. As you may notice, the `new_forest_plot_block` is a quite complex block. Part of the code is isolated in a function `create_ae_forest_plot` so that the main block constructor is more readable.
+
+```{r, eval=TRUE, echo=FALSE}
+card(
+ create_app_link(
+ "NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAdzgCMAnRRASwgGdSoAbbgCgA6YOtyIEA1gyG4ABAzioi7GQF4ZBQWAAWpUqnaIA9IZFjJAWiIMA5hmstSWgK50MLIodqNz8xe2kyQjp6Bsa+RBgM5tRQ7DAYVtZCAJTJAhBeTKwcXLyaphIMGKhaUAwwUABucAzscFAAJrAB4cpqGkG6+kYmooWWNnYOzq7unvRRrQGdIT3hkdGx8YkpaRDp3CyMZQCefAWSa5vbDHsNqNw7DEdbDLt8pCwNVzcnewBmVnCcF0Skr3dTvs+pJiqVylUanVGrA1ukAMQyABiTggBEeJBkpCI6nkUHIMka1VqcBkcGqZBkn3knBkv1I6QIePIAH0oHAWdTvqQWfSZAAecxU1Ho9wQPhNLiyJzsFwAKyeLOI3FkZRgSqIKsJcAacGIDQ1WogLPJFFI7GSMhA6RkMklUAFQvtMgAPgA+KksbjkBh8DD24DANWGgC6IZkAEI1EIAArcKAEehEFI2mSIgDCJGJpHUmqcMAgMmg8GU2JknAYbGs-kLMhl8sVysdhPYGAI4ITPr4sronAcTnIfHrdAVBuVqVTwabgpbbY76Jq3ZcfdIA7gfCnmontfZuv1hubsTnZU7i57K7XG51eqIY63cNrGZ4BCc8YJjlJ2NyRfzdBqMiId5y3lPVzRkNgyQTLRCXKVNjR7OVQOUGdnXdVNbTqbhQI3XgWUAvgNGHUdDVVcpDVSS00NrW0GhYPs0VIPhKLddCZGsBgiCcVAWToPYEw49h2Bw7g8PeDcyPHVJXRY6jgJgCpKzqPhCzUcVklkOwOK4tpAjABoONQFN1kfGR02fV98VJABBABRKl5AARycCgCBYb5CQgBo6QMqwMQ4ScOVleTdmbVCZNtW12M47jeI3JklCEngRPwjRNy1XcbzvbgKOY1igoUuj12NU0yB041aPo9E-QDYAiMbTUw3UmRNOinShH0ohDLAXLZKw94eTlIg2GUlkEKQ2ReNUGD1XHaTWJgAdLL4VAfIYPypuKikwMMIsH1tREAGU4Cw9EsU6mQADkZBgJQc3eRznMpWzlH4hLCV4aaa1tbFuPZZChXZUb8wUnY5tkqKuJ4vj4sE4TRKvPdb3IqSqIiuSCqUr8eBNLadKCkaSvNJqWu0qb2oMlIwbRn6WXFTazXYWQsZEwmLSpiLUFffgkvhjL90k9JU0RABxOAc1RFgnM-Zl4EpNUvs+5sJaliV8SgQM0sa1MWCAvgsIgaxHHEmA2ajGQACZLWtWTOE6zQABUtDoulRBzB6WBpMkAA9O0uLFqBxUgZbNT6MCM20AF9J1Fao2XKQ9ynYYAAEYQ1TYgyA4kS1QTk3gHNtPjP25EvR9KkrDO1AZGejyvIIcy31JeQ3xYao5Do8QApZBgGEPQLgZC1GIveUvF39NWNevfmGvDABSNhZ8rtlvh6tHUFbv4WWoJ5F1Y216u4HSefwvmkfHXA96LWBvk5DiYCm4+xLS9TL8qHhnPYW+iHv9oCdx2QICyBWp1XyYo1ho1XhFBaXBByXywFgKa48uCBlQLEcgAAGTQwDFBrTFCyAInZW4cjVMkMMMgdpIPVsAVBnA4CYKENg0BJB8F4FzJnTUccYCkJDBfWStpRC0AYEqFgU04Be1QHrIg1g+DwMtEKZOGAACcAA2GQAAqcsDk1qCD4RFZO5Dmo1RoRgzQ9NSosNVDHYh5RuEyAANSXzRvoihRi0F0NMTjBmFi2FBw4SQsh5hHF6IMZQlBbj6GQG8YQ2O-jwyBN0U4kJrjaERONAEDOvjs42LDJfVIvC0a2i4qgGowjRHiMkdI2R9iZAKJUeozR2ignOMMRPah4SPGsyiVYzhtiHEJOCS41pxj3FCDMeabxGSs49ICUE20zTQltJSR4gh3TYkyHiQUgp8zkkmNGRMkgmTpmF02duCBgsTIxl8GUUkzpqTlxpDmekqYuScBZM6GcgMe7s1tNApal94x-m4FNYZ9D+kLNPllMMsghAyE0PkzZLTkGLN2ZEzpKzHgxOyTw3ShgAgLJBcs1h0TrFcKhbpGQlRlDSCCfi9pey0WsMmX4rF0KwC4tYbSpZez0kHKmbE1laQwC5NYntNMplmSkheY812zyvg-FdjotGALjrkC9jmdodA2ANEVQUqVby1YABJlUqkvuwFabBSBiSELPDA5tdY2rteYB17xBWyD1faA18C3Vyp5B6gRJTXLeoefqrgBqikBpYOAiKL9ZLwCgCpe53IQ1QE9VgeF-CiCCKmu6w1-qhGBtYuG3uagc2hqLcI9N70WDWATR0MA3BphgCkN1St7E0BaG3g0RwU0JaMWUeg1l8kUiVsTF7Ka6ClGVs2BAOAWg4DVp0D2iADg+AAA5B0wGHaxOgRAvbsBYAAL1JGoCdABmAArCOzU2bUCZlELUfYu6yZNqIDsHgIhnIBGnce3STQGDiA-XAAI+UQrRhfW+7ggGt2yVIGqlk1gq4ltQPbNVwsJHGqmghsoBExHjqUU1R4EgdJYd9KOvDiimpewBZh1BpHcMnvwzGtGVGoB0GBW4zQWBjr4iITILAHdYXoqIZw1lBieXsKyTAAV0G0ZHo4lNZOU7qANAwHJnEahzZKZU65KamnWJqpYERqaGgJ2XpqbITTMgAAsTGIrsSeFNe2WAACqNlK2PFIFhdjtDOPcYxaSfj7BxAASAlZBoxI6gyBsrjQTRLVnlFE5S3SsgmWSek91VMawo7GRndQTkPreSux4iCZs7wRR+T9BgDAVs4JwDywcHVtoR7HQaDpTYnBGsRTqllDadXRrHVApyNy3BtVBKEM5g6zmABCAApAAkgAEWpf0srDExSqy4JaZUxZvgbagLZzZC1vQsAuD+pEVkAAyB03NBI815sDB0QKnUW6ZPMBYhC5MrbaNKvW8uYUG81kbnW0ZCCsume2VksAAFllsIuFGtkge2tuah20Je0B2ClHceKdqa52rs3f6Xdn9Qh7bByevHO9+Z1hCt0Rj77U8z7XtUn1-76IhsteBxFUHNkFs2XTAAeSW3gIJq3RSI-R7mbgqOkdfaga+bH93kSXeu7L76DhFfc5kPbGo99KfvZpyc2XYyyp9YgPmGohn2dA6aQOoJMAIJqDMxUMdGmB3lnIIh8zt31fE7ABdX8-5AJa-OjXMsC26IXCgDsD7tORWVrEStKaTk-jrmtpspk9RWSAz1fSPbGkhwIQPsTY25F88QtL81P+DNTkRQjhjgg8ZBLGc0ESKEHJCaFc3gcRt9JitmBkxFKrYdaxZfOYiLj9haG9w-OoGU2J77d4gPISfPo+8SB1bl-Lwbe8HHhTt59YWIukmiyHJEPqZBxj+LDu03wmQnfWmB9MErCSJtpHyIPreSRkhi8QGAtGqz+yBxk45jyzX4N6xB1A6R1qf51CeJkCd48jd6sIMJFZIG2ZsCczqq-pqwYD3TXzX6cR6ADjPpPI04PgZjP4z6cAJidxojTqGbYxBwsDYzUESDNib6sHiAb59YwjqgNas7kBeRgYwhAYtpCyejeglJsBr5cG2ab456oEghMTpAPh1AMCxycEET0H1wiRMEsFcASDJBgARwhhAA", # nolint
+ mode = "editor"
+ ),
+ full_screen = TRUE
+)
+```
+
+
+
+Toggle code
+
+
+
+
+
+```r
+library(dplyr)
+library(tidyr)
+library(forestplot)
+library(blockr.pharmaverseadam)
+
+# Function to create adverse event forest plot
+create_ae_forest_plot <- function(data, usubjid_col, arm_col, aedecod_col, n_events) {
+ data <- data |> filter(.data[[arm_col]] != "Placebo")
+ # Convert column names to strings
+ usubjid_col <- as.character(substitute(usubjid_col))
+ arm_col <- as.character(substitute(arm_col))
+ aedecod_col <- as.character(substitute(aedecod_col))
+
+ # Calculate the total number of subjects in each arm
+ n_subjects <- data |>
+ select(all_of(c(usubjid_col, arm_col))) |>
+ distinct() |>
+ group_by(across(all_of(arm_col))) |>
+ summarise(n = n(), .groups = "drop")
+
+ # Calculate AE frequencies and proportions
+ ae_summary <- data |>
+ group_by(across(all_of(c(arm_col, aedecod_col)))) |>
+ summarise(n_events = n_distinct(.data[[usubjid_col]]), .groups = "drop") |>
+ left_join(n_subjects, by = arm_col) |>
+ mutate(proportion = n_events / n)
+
+ # Select top N most frequent AEs across all arms
+ top_aes <- ae_summary |>
+ group_by(across(all_of(aedecod_col))) |>
+ summarise(total_events = sum(n_events), .groups = "drop") |>
+ top_n(n_events, total_events) |>
+ pull(all_of(aedecod_col))
+
+ # Get unique treatment arms
+ arms <- unique(data[[arm_col]])
+ if (length(arms) != 2) {
+ stop("This plot requires exactly two treatment arms.")
+ }
+ active_arm <- arms[1]
+ control_arm <- arms[2]
+
+ # Filter for top AEs and calculate relative risk
+ ae_rr <- ae_summary |>
+ filter(.data[[aedecod_col]] %in% top_aes) |>
+ pivot_wider(
+ id_cols = all_of(aedecod_col),
+ names_from = all_of(arm_col),
+ values_from = c(n_events, n, proportion)
+ ) |>
+ mutate(
+ RR = .data[[paste0("proportion_", active_arm)]] / .data[[paste0("proportion_", control_arm)]],
+ lower_ci = exp(log(RR) - 1.96 * sqrt(
+ 1 / .data[[paste0("n_events_", active_arm)]] +
+ 1 / .data[[paste0("n_events_", control_arm)]] -
+ 1 / .data[[paste0("n_", active_arm)]] -
+ 1 / .data[[paste0("n_", control_arm)]]
+ )),
+ upper_ci = exp(log(RR) + 1.96 * sqrt(
+ 1 / .data[[paste0("n_events_", active_arm)]] +
+ 1 / .data[[paste0("n_events_", control_arm)]] -
+ 1 / .data[[paste0("n_", active_arm)]] -
+ 1 / .data[[paste0("n_", control_arm)]]
+ ))
+ )
+
+ # Prepare data for forest plot
+ forest_data <- ae_rr |>
+ mutate(
+ label = paste0(
+ .data[[aedecod_col]], " (",
+ .data[[paste0("n_events_", active_arm)]], "/", .data[[paste0("n_", active_arm)]], " vs ",
+ .data[[paste0("n_events_", control_arm)]], "/", .data[[paste0("n_", control_arm)]], ")"
+ )
+ )
+
+ # Create forest plot
+ forestplot::forestplot(
+ labeltext = cbind(
+ forest_data$label,
+ sprintf("%.2f (%.2f-%.2f)", forest_data$RR, forest_data$lower_ci, forest_data$upper_ci)
+ ),
+ mean = forest_data$RR,
+ lower = forest_data$lower_ci,
+ upper = forest_data$upper_ci,
+ align = c("l", "r"),
+ graphwidth = unit(60, "mm"),
+ cex = 0.9,
+ lineheight = unit(8, "mm"),
+ boxsize = 0.35,
+ col = fpColors(box = "royalblue", line = "darkblue", summary = "royalblue"),
+ txt_gp = fpTxtGp(label = gpar(cex = 0.9), ticks = gpar(cex = 0.9), xlab = gpar(cex = 0.9)),
+ xlab = paste("Relative Risk (", active_arm, " / ", control_arm, ")"),
+ zero = 1,
+ lwd.zero = 2,
+ lwd.ci = 2,
+ xticks = c(0.5, 1, 2, 4),
+ grid = TRUE,
+ title = paste("Relative Risk of Adverse Events (", active_arm, " vs ", control_arm, ")")
+ )
+}
+
+new_forest_plot_block <- function(...) {
+ new_block(
+ fields = list(
+ usubjid_col = new_select_field(
+ "USUBJID",
+ function(data) colnames(data),
+ multiple = FALSE,
+ title = "Subject ID Column"
+ ),
+ arm_col = new_select_field(
+ "ACTARM",
+ function(data) colnames(data),
+ multiple = FALSE,
+ title = "Treatment Arm Column"
+ ),
+ aedecod_col = new_select_field(
+ "AEDECOD",
+ function(data) colnames(data),
+ multiple = FALSE,
+ title = "AE Term Column"
+ ),
+ n_events = new_numeric_field(
+ 10,
+ min = 5, max = 20, step = 1,
+ title = "Number of Top AEs to Display"
+ )
+ ),
+ expr = quote({
+ create_ae_forest_plot(data, .(usubjid_col), .(arm_col), .(aedecod_col), .(n_events))
+ }),
+ class = c("adverse_event_plot_block", "plot_block"),
+ ...
+ )
+}
+
+# Register the custom block
+register_block(
+ new_forest_plot_block,
+ name = "Adverse Event Forest Plot",
+ description = "Create a forest plot of adverse events comparing two treatment arms",
+ classes = c("adverse_event_plot_block", "plot_block"),
+ input = "data.frame",
+ output = "plot"
+)
+
+# Create the stack
+clinical_trial_stack <- new_stack(
+ new_adam_block(selected = "adae"),
+ # filter_in_block(),
+ new_forest_plot_block()
+)
+
+serve_stack(clinical_trial_stack)
+```
+
+
+#### 2.2 Demographics Table
+
+This demographics table is taken from the `{cardinal}` package of [FDA Safety Tables and Figures](https://github.com/pharmaverse/cardinal) and demonstrates `{gt}` and `{rtables}` outputs starting from the [pharmaverseadam](https://github.com/pharmaverse/pharmaverseadam) `adsl` dataset. As a side note, the below block requires some extra helpers to work properly which you can find [here](https://github.com/blockr-org/blockr.cardinal/blob/72e6e5518d8226d4fdeb599b6e2e31ba03dc7c82/R/methods.R) in the `{blockr.cardinal}` package.
+
+```{r cardinal_tables, eval=FALSE}
+library(shiny)
+library(blockr)
+library(cardinal)
+library(blockr.pharmaverseadam)
+
+new_cardinal02_block <- function(...) {
+ all_cols <- function(data) colnames(data)
+
+ fields <- list(
+ columns = new_select_field(
+ c("SEX", "AGE", "AGEGR1", "RACE", "ETHNIC", "COUNTRY"),
+ all_cols,
+ multiple = TRUE,
+ title = "Variables"
+ )
+ )
+
+ expr <- quote({
+ data <- droplevels(data)
+
+ rtables <- cardinal::make_table_02(
+ df = data,
+ vars = .(columns)
+ )
+
+ gt <- cardinal::make_table_02_gtsum(
+ df = data,
+ vars = .(columns)
+ )
+
+ list(
+ rtables = rtables,
+ gt = gt
+ )
+ })
+
+ new_block(
+ expr = expr,
+ fields = fields,
+ ...,
+ class = c("cardinal02_block", "rtables_block", "submit_block")
+ )
+}
+
+register_block(
+ new_cardinal02_block,
+ "Cardinal 02",
+ "A Cardinal 02 table",
+ input = "data.frame",
+ output = "list",
+ classes = c("cardinal02_block", "rtables_block", "submit_block")
+)
+
+
+# Create the stack
+rtables_stack <- new_stack(
+ new_adam_block(selected = "adsl"),
+ new_cardinal02_block()
+)
+
+serve_stack(rtables_stack)
+```
+
+```{r blockr-cardinal, echo=FALSE, fig.cap='Cardinal demo', fig.align = 'center', out.width='100%'}
+knitr::include_graphics("figures/blockr-cardinal-demo.png")
+```
+
+### 3. Environmental Science: Air Quality Analysis and Prediction
+
+This example demonstrates a pipeline for analyzing air quality data and predicting future pollution levels using actual data from the [openair](https://github.com/cran/openair) package.
+This pipeline imports actual air quality data from the `{openair}` package and forecasts future pollution levels using an ARIMA model.
+
+```{r environment, eval=FALSE}
+library(blockr)
+library(openair)
+library(forecast)
+
+# Custom block for air quality data import
+new_air_quality_block <- function(...) {
+ new_block(
+ fields = list(
+ site = new_select_field(
+ "kc1",
+ \() openair::importMeta()$code,
+ multiple = FALSE,
+ title = "Monitoring Site"
+ ),
+ start_year = new_numeric_field(
+ 2020,
+ min = 1990,
+ max = as.numeric(format(Sys.Date(), "%Y")),
+ step = 1,
+ title = "Start Year"
+ ),
+ end_year = new_numeric_field(
+ as.numeric(format(Sys.Date(), "%Y")),
+ min = 1990,
+ max = as.numeric(format(Sys.Date(), "%Y")),
+ step = 1,
+ title = "End Year"
+ )
+ ),
+ expr = quote({
+ importAURN(site = .(site), year = .(start_year):.(end_year)) |> tail(700)
+ }),
+ class = c("air_quality_block", "data_block"),
+ ...
+ )
+}
+
+
+# Custom block for pollution forecasting
+new_pollution_forecast_block <- function(columns = character(), ...) {
+ all_cols <- function(data) setdiff(colnames(data), c("date", "site", "source"))
+
+ new_block(
+ fields = list(
+ pollutant = new_select_field(columns, all_cols, multiple = FALSE, title = "Pollutant"),
+ horizon = new_slider_field(
+ 30,
+ min = 1,
+ max = 365,
+ step = 1,
+ title = "Forecast Horizon (days)"
+ )
+ ),
+ expr = quote({
+ ts_data <- ts(na.omit(data[[.(pollutant)]]), frequency = 365)
+ model <- auto.arima(ts_data)
+ forecast_result <- forecast(model, h = .(horizon))
+ plot(forecast_result, main = paste("Forecast of", .(pollutant), "levels"))
+ }),
+ class = c("pollution_forecast_block", "plot_block"),
+ ...
+ )
+}
+
+# Register custom blocks
+register_block(
+ new_air_quality_block,
+ name = "Air Quality Data",
+ description = "Import air quality data",
+ classes = c("air_quality_block", "data_block"),
+ input = NA_character_,
+ output = "data.frame"
+)
+
+register_block(
+ new_pollution_forecast_block,
+ name = "Pollution Forecast",
+ description = "Forecast pollution levels",
+ classes = c("pollution_forecast_block", "plot_block"),
+ input = "data.frame",
+ output = "plot"
+)
+
+# Create the stack
+air_quality_stack <- new_stack(
+ new_air_quality_block(),
+ new_pollution_forecast_block(columns = "no2")
+)
+
+serve_stack(air_quality_stack)
+```
+
+### 4. Marketing: Causal Impact Analysis of Marketing Interventions
+
+This example demonstrates how to use [CausalImpact](https://google.github.io/CausalImpact/CausalImpact.html) to analyze the effect of marketing interventions on sales data.
+This pipeline generates dummy marketing data with an intervention, then uses `{CausalImpact}` to analyze the effect of the intervention on sales. This requires to define a new date field as shown below.
+
+```{r date_field}
+library(shiny)
+new_date_field <- function(value = Sys.Date(), min = NULL, max = NULL, ...) {
+ blockr::new_field(
+ value = value,
+ min = min,
+ max = max,
+ ...,
+ class = "date_field"
+ )
+}
+
+date_field <- function(...) {
+ validate_field(new_date_field(...))
+}
+
+#' @method ui_input date_field
+#' @export
+ui_input.date_field <- function(x, id, name) {
+ shiny::dateInput(
+ blockr::input_ids(x, id),
+ name,
+ value = blockr::value(x, "value"),
+ min = blockr::value(x, "min"),
+ max = blockr::value(x, "max")
+ )
+}
+
+#' @method validate_field date_field
+#' @export
+validate_field.date_field <- function(x, ...) {
+ x
+}
+
+#' @method ui_update date_field
+#' @export
+ui_update.date_field <- function(x, session, id, name) {
+ updateDateInput(
+ session,
+ blockr::input_ids(x, id),
+ blockr::get_field_name(x, name),
+ value = blockr::value(x),
+ min = blockr::value(x, "min"),
+ max = blockr::value(x, "max")
+ )
+}
+```
+
+```{r intervention_impact, eval=FALSE}
+library(blockr)
+library(CausalImpact)
+library(dplyr)
+
+# Custom block to load and prepare marketing data
+new_marketing_data_block <- function(...) {
+ new_block(
+ fields = list(
+ start_date = date_field(
+ Sys.Date() - 365,
+ min = Sys.Date() - 730,
+ max = Sys.Date() - 1,
+ label = "Start Date"
+ ),
+ intervention_date = date_field(
+ Sys.Date() - 180,
+ min = Sys.Date() - 729,
+ max = Sys.Date(),
+ label = "Intervention Date"
+ ),
+ end_date = date_field(
+ Sys.Date(),
+ min = Sys.Date() - 364,
+ max = Sys.Date(),
+ label = "End Date"
+ )
+ ),
+ expr = quote({
+ # Generate dummy data for demonstration
+ dates <- seq(as.Date(.(start_date)), as.Date(.(end_date)), by = "day")
+ sales <- cumsum(rnorm(length(dates), mean = 100, sd = 10))
+ ad_spend <- cumsum(rnorm(length(dates), mean = 50, sd = 5))
+
+ # Add intervention effect
+ intervention_index <- which(dates == as.Date(.(intervention_date)))
+ sales[intervention_index:length(sales)] <- sales[intervention_index:length(sales)] * 1.2
+
+ data.frame(
+ date = dates,
+ sales = sales,
+ ad_spend = ad_spend
+ )
+ }),
+ class = c("marketing_data_block", "data_block"),
+ ...
+ )
+}
+
+# Custom block for CausalImpact analysis
+new_causal_impact_block <- function(columns = character(), ...) {
+ all_cols <- function(data) colnames(data)[2:length(colnames(data))]
+
+ new_block(
+ fields = list(
+ response_var = new_select_field(
+ columns,
+ all_cols,
+ multiple = FALSE,
+ title = "Response Variable"
+ ),
+ covariate_var = new_select_field(
+ columns,
+ all_cols,
+ multiple = FALSE,
+ title = "Covariate Variable"
+ ),
+ pre_period_end = date_field(
+ Sys.Date() - 181,
+ min = Sys.Date() - 729,
+ max = Sys.Date() - 1,
+ label = "Pre-Period End Date"
+ ),
+ post_period_start = date_field(
+ Sys.Date() - 180,
+ min = Sys.Date() - 728,
+ max = Sys.Date(),
+ label = "Post-Period Start Date"
+ )
+ ),
+ expr = quote({
+ data <- data.frame(
+ date = data$date,
+ y = data[[.(response_var)]],
+ x = data[[.(covariate_var)]]
+ )
+ pre_period <- c(min(as.Date(data$date)), as.Date(.(pre_period_end)))
+ post_period <- c(as.Date(.(post_period_start)), max(as.Date(data$date)))
+
+ impact <- CausalImpact(data, pre_period, post_period)
+ plot(impact)
+ }),
+ class = c("causal_impact_block", "plot_block"),
+ ...
+ )
+}
+
+# Register custom blocks
+register_block(
+ new_marketing_data_block,
+ name = "Marketing Data",
+ description = "Load and prepare marketing data",
+ classes = c("marketing_data_block", "data_block"),
+ input = NA_character_,
+ output = "data.frame"
+)
+register_block(
+ new_causal_impact_block,
+ name = "Causal Impact Analysis",
+ description = "Perform Causal Impact analysis on marketing data",
+ classes = c("causal_impact_block", "plot_block"),
+ input = "data.frame",
+ output = "plot"
+)
+
+# Create the stack
+marketing_impact_stack <- new_stack(
+ new_marketing_data_block(),
+ new_causal_impact_block()
+)
+
+serve_stack(marketing_impact_stack)
+```
+
+```{r blockr-marketing, echo=FALSE, fig.cap='Marketing demo', fig.align = 'center', out.width='100%'}
+knitr::include_graphics("figures/blockr-marketing-demo.png")
+```
+
+### 5. Dynamical systems
+
+In the below example, we implemented the Lorenz attractor and solve it with the `{pracma}` R package (technically, the reason using `{pracma}` over `{deSolve}` or `{diffeqr}` is because only `{pracma}` is available for shinylive required by the embeded demo).
+
+```{r, eval=TRUE, echo=FALSE}
+card(
+ create_app_link(
+ "NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAdzgCMAnRRASwgGdSoAbbgCgA6YOtyIEA1gyG4ABAzioi7GQF4ZBQWAAWpUqnaIA9IZFjJAWiIMA5hmstSWgK50MLIodqNz8xe2kyQjp6Bsa+RBgM5tRQ7DAYVtZCAJTJAhBeTKwcXLyaphIMdtaooqQATAHhymoaQbr6RiaihZY2dg7Oru6e9FHVAfUhTeGR0bHxiSlpEOncLIxQDACefAWSM-OLK3yoDFAEMFCbC-s760XWJWXlM+kQcNQA+kQAJnBP6zIAPOYyAGZOCAEUjuCB8DCQ5IyEDpdIyGSieQQABePz+gOBoJIMj4pFky1kqCWMHY0NhEARCLqlKpCIAGqoZMSGKTgABGAC6MgAVDJlhzuQBqfnAcrcvkCgDMnNw8LpMgAmkyWWzxbzcQL1X9pZzknLaXSAFpM8wCrkarXC5kk9jAGWWsXcnX2znyhEzBEAXzhtP+LDg3Feyl+iJYnEEhpkUCZD2eECc8AYLAIT39gdefHMAA5DFLZOZ2QAGWTlIv690yOixx5PBNJlNpgNBrPFgsAVhLMmL5YNdIINfjibgydT6Zb5WzsnZ06L5fld1pcc+LXEkbp4+DTM37D7VLgAA89kz2C5OA4nOR1wrYhhXlAuBh-vt4NeFTI3nAACztt-vgFArIlbvssRZMhojJqDOSpMtBJpQRWUbvqQYFqCWwEKqQ-rQNwsFznu-42qyNTqBCfDHLIGBrPqMhUQQqQYR6GGIe+8wRpiTJIhQKKelSLFUpCGAEeo3CxCRdRgJ+K5mIMYD3lw0kSCkC7pD6sw5Ac4jojIy6cJp17LlJ6xAUutZXKURCkIpa6VpiA61JoB6ycsKQmXS7z-FATjcFZxDcImHDgZoywYOyzkYJUYC8TR8rLtYcBEDAihsFZ6zpDM7AjgAbh8ekSHweXiMkYBepyQA", # nolint
+ mode = "editor"
+ ),
+ full_screen = TRUE
+)
+```
+
+
+
+Toggle code
+
+
+
+
+
+```r
+library(blockr)
+library(pracma)
+library(blockr.ggplot2)
+
+new_ode_block <- function(...) {
+
+ lorenz <- function (t, y, parms) {
+ c(
+ X = parms[1] * y[1] + y[2] * y[3],
+ Y = parms[2] * (y[2] - y[3]),
+ Z = -y[1] * y[2] + parms[3] * y[2] - y[3]
+ )
+ }
+
+ fields <- list(
+ a = new_numeric_field(-8/3, -10, 20),
+ b = new_numeric_field(-10, -50, 100),
+ c = new_numeric_field(28, 1, 100)
+ )
+
+ new_block(
+ fields = fields,
+ expr = substitute(
+ as.data.frame(
+ ode45(
+ fun,
+ y0 = c(X = 1, Y = 1, Z = 1),
+ t0 = 0,
+ tfinal = 100,
+ parms = c(.(a), .(b), .(c))
+ )
+ ),
+ list(fun = lorenz)
+ ),
+ ...,
+ class = c("ode_block", "data_block")
+ )
+}
+
+stack <- new_stack(
+ new_ode_block,
+ # Coming from blockr.ggplot2
+ new_ggplot_block(
+ func = c("x", "y"),
+ default_columns = c("y.1", "y.2")
+ ),
+ new_geompoint_block
+)
+serve_stack(stack)
+```
+
diff --git a/vignettes/developer-guide.Rmd b/vignettes/developer-guide.Rmd
index 49491cfe..6be8b159 100644
--- a/vignettes/developer-guide.Rmd
+++ b/vignettes/developer-guide.Rmd
@@ -123,7 +123,7 @@ for checking that the value is a character string and modifies it if not.
TBD
-## Validation and evaluation
+# Validation and evaluation
That's currently how {blockr} validate blocks and fields. Each block is validated, meaning that each field that compose it should have valid values according to the input data. Only when everything is valid, the block expression is evaluated and the result computed and passed to the next block. Any error is catched by R and forwarded to JavaScript so that users are notified about what went wrong and where.
@@ -156,7 +156,7 @@ flowchart TD;
subgraph ui
gui[User interface]
end
-", height = "1200px") |>
+", height = "1250px") |>
htmlwidgets::onRender("
function(el, x) {
el.classList.add('text-center')
diff --git a/vignettes/figures/blockr-cardinal-demo.png b/vignettes/figures/blockr-cardinal-demo.png
new file mode 100644
index 00000000..1e014bbd
Binary files /dev/null and b/vignettes/figures/blockr-cardinal-demo.png differ
diff --git a/vignettes/figures/blockr-marketing-demo.png b/vignettes/figures/blockr-marketing-demo.png
new file mode 100644
index 00000000..fee9ad30
Binary files /dev/null and b/vignettes/figures/blockr-marketing-demo.png differ
diff --git a/vignettes/figures/blockr-penguins-stack.png b/vignettes/figures/blockr-penguins-stack.png
new file mode 100644
index 00000000..a12a1d6f
Binary files /dev/null and b/vignettes/figures/blockr-penguins-stack.png differ
diff --git a/vignettes/figures/blockr-stock-demo.png b/vignettes/figures/blockr-stock-demo.png
new file mode 100644
index 00000000..c69de0bb
Binary files /dev/null and b/vignettes/figures/blockr-stock-demo.png differ
diff --git a/vignettes/new-field.Rmd b/vignettes/new-field.Rmd
new file mode 100644
index 00000000..17f84ebd
--- /dev/null
+++ b/vignettes/new-field.Rmd
@@ -0,0 +1,166 @@
+---
+title: "4. Case study: create a new field"
+output: rmarkdown::html_vignette
+vignette: >
+ %\VignetteIndexEntry{4. Case study: create a new field}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\VignetteEncoding{UTF-8}
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+ collapse = TRUE,
+ comment = "#>"
+)
+```
+
+```{r setup, include=FALSE}
+library(blockr)
+library(bslib)
+```
+
+
+In this vignette, we show how to create a new field, that is the `slider_field`, similar to the range field with only 1 value.
+
+## Introduction
+
+To create a field, we first need to design a __constructor__. In our case, we call it `new_slider_field`.
+Since fields are mirroring shiny inputs, we can naturally provide the corresponding input parameters that are the value, minimum, maximum and step. We pass all of these to `blockr::new_field()` and give it a custom class `slider_field`.
+
+```{r slider_field}
+new_slider_field <- function(
+ value = numeric(),
+ min = numeric(),
+ max = numeric(),
+ step = numeric(),
+ ...) {
+ blockr::new_field(
+ value = value,
+ min = min,
+ max = max,
+ step = step,
+ ...,
+ class = "slider_field"
+ )
+}
+```
+
+On the UI side, this is fairly straightforward as all we have to do is call `shiny::sliderInput` with the same parameters given in the above constructor.
+
+```{r, ui-slider-field}
+ui_input.slider_field <- function(x, id, name) {
+ shiny::sliderInput(
+ blockr::input_ids(x, id),
+ name,
+ value = blockr::value(x, "value"),
+ min = blockr::value(x, "min"),
+ max = blockr::value(x, "max"),
+ step = blockr::value(x, "step")
+ )
+}
+```
+
+The next step consists in validating the field to ensure provided values are correct. For instance,
+we want to make sure all passed elements are numbers. This is done within the `validate_field.slider_field` method. We extract all the field element values with `blockr::value(x, "element")` and use the suitable validate function, that is `validate_number()`. Note that if nothing is provided, the validation falls back to `validate_field.field()`, which does nothing.
+
+```{r, validate-slider-field}
+validate_field.slider_field <- function(x) {
+ val <- value(x)
+ min <- value(x, "min")
+ max <- value(x, "max")
+ step <- value(x, "step")
+
+ validate_number(val)
+
+ if (length(min)) {
+ validate_number(min, "min")
+ }
+
+ if (length(max)) {
+ validate_number(max, "max")
+ }
+
+ if (length(step)) {
+ validate_number(step, "step")
+ }
+
+ NextMethod()
+}
+```
+
+Finally, we want to make sure that we can update the field with the `ui_update.slider_field()` method. This is needed whenever another field would have to update the slider field, because of a possible __dependency__ between these 2 fields. As an example, this is what currently happens in the __filter block__ where the selected column field updates the value field (the field type changes depending on the column type).
+
+```{r, update-slider-field}
+ui_update.slider_field <- function(x, session, id, name) {
+ updateSliderInput(
+ session,
+ blockr::input_ids(x, id),
+ blockr::get_field_name(x, name),
+ blockr::value(x),
+ blockr::value(x, "min"),
+ blockr::value(x, "max"),
+ blockr::value(x, "step")
+ )
+}
+```
+
+## Example
+
+We can test our newly created field in a custom block.
+
+```{r, eval=TRUE, echo=FALSE}
+card(
+ create_app_link(
+ "NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAdzgCMAnRRASwgGdSoAbbgCgA6YOtyIEA1gyG4ABAzioi7GQF4ZBQWAAWpUqnaIA9IZFjJAWiIMA5hmstSWgK50MLIodqNz8xe2kyQjp6Bsa+RBgM5tRQ7DAYVtZCAJTJAhDp3CyMUAwAnnymEgxpGRAQcNQA+uxZACZwDFUAZixw3HUyADzmMs1OEASk7hCCEDITMgBuPE5wqjIQTvAMLBrJuOmTMjBsC0sra3wbW5MwUAAe+8uNRyfjk5wK14frmw8TGF-JMiCnRZJmBVqq12nUxtsZtw5gsoXN3ttduM1EiEWdLgtzhc0RMnqgFnicTIvhgiQRuLFlGohLUWA0mqCOkJTqUAL7pdJOFhVNioJykDC0+ktNodbq9fqDYYkPjYmR02TQeA-P4PdhaNh5ZhCxoASQgfNIEMmAKYrAN-J5dXYstkdPu2yVcCJcPmalNzFdtsCYFdKSJSIWHsQXrlQiR-tOEyxQdExU9szg3vDl0jHxkeNjZjNodkNPIqBSLPS7LKULpUHIIrBgvqjWrYp6fQGQxGspVpyh4umifbp0DTdzPojYFK0Yxg97YbAWKLaoL3aH+YUc87PArVYOdEafChpVOLGaMj43Ao1kcfCRqV+UZ79UrcCqW53qOHbDnE1LB6PJ7PF6x16qpC651A+T7LNuDCXpceYzqmo6nF+DyHsep4QOeWh8HigG3uWoGbhBO6Ej6eIfjISETAAcnAFykAAsnAjhEOCbIcks3JOKg+FwLWdL1oynRNpKrYynK7BwOw7AjHadSKrAcAdg8nHcQAynWDD6oaxq4hJUkkESwa8padI2nK9pEk6BlxoCIZTg6JrWTmU6wSO9kTMGS5wRcabbB5zkkQWZGsWU8j2E8DAqQAzPATHgkIXI8hapABDS6kNnUAQJUZAo6gyop1KUoUsOFUUxVozGaAlykPilYC5elmUcVxD68cKAn7uUlQ1FkBCPgC3bCdKozNAwRAwAsAAMsgkoppwQFUo3UMoTYCAIfD4VAPwQIt62VptbETAJy29FknDaXIRBLfsXX1QJ50TK6CwjWNRLRnsahTbe45XGo82Lewr0ZguagAIyA8MpCngsQgqe0cBDBdS3MumY4yB1EzAlUALnUdT35QDt40agDALAAjk4RDkOtqDcHkZq0r1WFwKTVRoXwGB8P9qSpBZ8nQ2Aal8STDPzAC0i3iSZIUpJCwaKlax9dZtWkAwUAcM0VgwFjSsIQ8wXpOJDBTI+nBQBIxqY6b5u3pjG3iaQ2tmJoLCrP4o4WTdPWK07ACsqOlMkYCsgAukAA", # nolint
+ mode = "editor"
+ ),
+ full_screen = TRUE
+)
+```
+
+
+
+Toggle code
+
+
+
+
+
+```r
+new_slice_block <- function(from = 0, ...) {
+
+ n_rows <- \(data) nrow(data)
+
+ fields <- list(
+ rows = new_slider_field(
+ value = from,
+ min = 0,
+ max = n_rows,
+ step = 1,
+ title = "Select rows"
+ )
+ )
+
+ new_block(
+ fields = fields,
+ expr = quote(dplyr::slice(seq_len(.(rows)))),
+ name = "Slider slice block",
+ ...,
+ class = c("slice_block", "transform_block")
+ )
+}
+
+serve_stack(
+ new_stack(
+ new_dataset_block("iris"),
+ new_slice_block(5)
+ )
+)
+```
+
diff --git a/vignettes/registry.Rmd b/vignettes/registry.Rmd
index 5391e349..bb2bd693 100644
--- a/vignettes/registry.Rmd
+++ b/vignettes/registry.Rmd
@@ -17,6 +17,7 @@ knitr::opts_chunk$set(
```{r setup, echo=FALSE, message=FALSE}
library(blockr)
library(bslib)
+library(DiagrammeR)
note_box <- function(..., color) {
htmltools::div(
@@ -48,6 +49,46 @@ metadata:
- Returned __output__.
- ...
+In other words, the __registry__ is a __"supermarket"__ for data analysis. As shown below, if you develop your own blocks package and registers blocks on load, these blocks become available to the end user. Therefore this makes it powerful for __collaboration__ between data science teams.
+
+```{r, echo=FALSE}
+
+mermaid("
+ flowchart LR
+ subgraph blockr_ggplot2[blockr.ggplot2]
+ new_block1[New block]
+ new_block2[New block]
+ end
+ subgraph blockr_echarts4r[blockr.echarts4r]
+ new_block3[New block]
+ new_block4[New block]
+ end
+ blockr_ggplot2 --> |register| registry
+ blockr_echarts4r --> |register| registry
+ subgraph registry[Registry]
+ subgraph select_reg[Select block]
+ reg_name[Name: select block]
+ reg_descr[Description: select columns in a table]
+ reg_classes[Classes: select_block, tranform_block]
+ reg_input[Input: data.frame]
+ reg_output[Output: data.frame]
+ reg_package[Package: blockr]
+ end
+ subgraph filter_reg[Filter block]
+ end
+ filter_reg --x |unregister| trash['fa:fa-trash']
+ end
+ ",
+ height = "600px"
+) |>
+ htmlwidgets::onRender(
+ "function(el, x) {
+ el.classList.add('text-center')
+ }
+ "
+ )
+```
+
## Previewing available blocks
Upon loading, `{blockr}` __registers__ its internal __blocks__ with `register_blockr_blocks()`.
+