From d5e76cfd3b55994fdb555bb4da5841dee6d70e7f Mon Sep 17 00:00:00 2001 From: John Coene Date: Fri, 16 Feb 2024 13:37:27 +0100 Subject: [PATCH] chore: remove demo blocks --- DESCRIPTION | 4 +- NAMESPACE | 17 -- R/demo-bms-blocks.R | 463 -------------------------------------------- R/utils.R | 71 +------ man/demo_block.Rd | 42 ---- man/plot_block.Rd | 59 ------ 6 files changed, 3 insertions(+), 653 deletions(-) delete mode 100644 R/demo-bms-blocks.R delete mode 100644 man/demo_block.Rd delete mode 100644 man/plot_block.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 4a9f0ae..a87be97 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -33,9 +33,7 @@ Imports: shiny, admiral, dplyr, - rlang, - ggplot2, - ggiraph + rlang Remotes: blockr-org/blockr Suggests: diff --git a/NAMESPACE b/NAMESPACE index 1ffe929..b94b5c5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,8 +2,6 @@ S3method(layout,code_plot_block) S3method(layout,code_transform_block) -S3method(server_output,ggiraph_block) -S3method(uiOutputBlock,ggiraph_block) S3method(ui_fields,admiral_dpc_block) S3method(ui_fields,filter_expr_block) S3method(ui_fields,summarize_expr_block) @@ -11,30 +9,15 @@ S3method(ui_input,code_field) S3method(ui_update,code_field) S3method(validate_field,code_field) export(admiral_dpc_block) -export(asfactor_block) export(code_field) export(code_plot_block) export(code_transform_block) -export(demo_arrange_block) -export(demo_data_block) -export(demo_filter_block_1) -export(demo_filter_block_2) -export(demo_group_by_block) -export(demo_join_block) -export(demo_summarize_block) export(filter_expr_block) -export(ggiraph_block) -export(new_asfactor_block) export(new_code_field) export(new_code_plot_block) export(new_code_transform_block) -export(new_ggiraph_block) -export(new_plot_block) -export(plot_block) export(summarize_expr_block) import(blockr) -import(ggiraph) -import(ggplot2) importFrom(admiral,derive_param_computed) importFrom(dplyr,filter) importFrom(rlang,exprs) diff --git a/R/demo-bms-blocks.R b/R/demo-bms-blocks.R deleted file mode 100644 index 2e8f794..0000000 --- a/R/demo-bms-blocks.R +++ /dev/null @@ -1,463 +0,0 @@ -#' Monolithic ggplot block -#' -#' Used with cdisc data. See \link{demo_data_block}. -#' -#' @inheritParams blockr::server_output -#' @inheritParams blockr::uiOutputBlock -#' @param data Tabular data in which to select some columns. -#' @param plot_opts List containing options for ggplot (color, ...). -#' @param ... Any other params. TO DO -#' @rdname plot_block -#' @import ggplot2 -#' @import blockr -#' @export -new_plot_block <- function( - data, - plot_opts = list( - colors = c("blue", "red"), # when outside aes ... - point_size = 3, - title = "Plot title", - theme = c( - "theme_minimal", - "theme_gray", - "theme_linedraw", - "theme_dark", - "theme_light", - "theme_classic", - "theme_void", - "theme_bw" - ), - x_lab = "X axis label", - y_lab = "Y axis label", - errors = list( - show = FALSE, - ymin = character(), - ymax = character() - ), - lines = list( - show = FALSE, - group = character(), - color = character() - ) - ), - ...) { - # For plot blocks, fields will create input to style the plot ... - all_cols <- function(data) colnames(data) - fields <- list( - x_var = new_select_field("VISIT", all_cols), - y_var = new_select_field("MEAN", all_cols), - color = new_select_field("ACTARM", all_cols), - shape = new_select_field("ACTARM", all_cols), - point_size = new_range_field(plot_opts$point_size, min = 1, max = 10), - title = new_string_field(plot_opts$title), - x_lab = new_string_field(plot_opts$x_lab), - y_lab = new_string_field(plot_opts$y_lab), - theme = new_select_field(plot_opts$theme[[1]], plot_opts$theme), - errors_toggle = new_switch_field(plot_opts$errors$show), - lines_toggle = new_switch_field(plot_opts$lines$show) - ) - - new_block( - fields = fields, - expr = quote({ - x_var <- .(x_var) - y_var <- .(y_var) - color <- .(color) - shape <- .(shape) - ymin <- "ymin" - ymax <- "ymax" - - p <- ggplot(data) + - geom_point( - # We have to use aes_string over aes - mapping = aes( - x = .data[[x_var]], - y = .data[[y_var]], - color = .data[[color]], - shape = .data[[shape]] - ), - size = 3 # .(point_size) TO DO: allow slide to have 1 value - ) - - # Adding errors - if (.(errors_toggle)) { - p <- p + geom_errorbar( - aes( - x = .data[[x_var]], - y = .data[[y_var]], - ymin = MEAN - SE, - ymax = MEAN + SE, - color = ACTARM - ), - width = 0.2 - ) - } - - if (.(lines_toggle)) { - p <- p + geom_line( - aes( - x = .data[[x_var]], - y = .data[[y_var]], - group = .data[[color]], - color = .data[[color]] - ) - ) - } - - p + - labs( - title = .(title), - x = .(x_lab), - y = .(y_lab) - ) + - # theme_update(.(theme)) + - theme( - axis.text.x = element_text(angle = 45, hjust = 1), - legend.title = element_text(face = "bold"), - legend.position = "bottom" - ) + - scale_color_brewer(name = "Treatment Group", palette = "Set1") + - scale_shape_manual( - name = "Treatment Group", - values = c(16, 17, 18, 19, 20) - ) - }), - ..., - class = c("plot_block", "submit_block") - ) -} - -#' @rdname plot_block -#' @export -plot_block <- function(data, ...) { - initialize_block(new_plot_block(data, ...), data) -} - -#' Monolithic ggiraph plot block -#' -#' To use with \link{demo_data_block} as data input. -#' -#' @param data Tabular data in which to select some columns. -#' @param plot_opts List containing options for ggplot (color, ...). -#' @param ... Any other params. TO DO -#' @rdname plot_block -#' @import ggiraph -#' @export -new_ggiraph_block <- function( - data, - plot_opts = list( - colors = c("blue", "red"), # when outside aes ... - point_size = 3, - title = "Plot title", - theme = c( - "theme_minimal", - "theme_gray", - "theme_linedraw", - "theme_dark", - "theme_light", - "theme_classic", - "theme_void", - "theme_bw" - ), - x_lab = "X axis label", - y_lab = "Y axis label", - errors = list( - show = TRUE, - ymin = character(), - ymax = character() - ), - lines = list( - show = TRUE, - group = character(), - color = character() - ) - ), - ...) { - # For plot blocks, fields will create input to style the plot ... - all_cols <- function(data) colnames(data) - fields <- list( - x_var = new_select_field("VISIT", all_cols), - y_var = new_select_field("MEAN", all_cols), - color = new_select_field("ACTARM", all_cols), - shape = new_select_field("ACTARM", all_cols), - point_size = new_range_field(plot_opts$point_size, min = 1, max = 10), - title = new_string_field(plot_opts$title), - x_lab = new_string_field(plot_opts$x_lab), - y_lab = new_string_field(plot_opts$y_lab), - errors_toggle = new_switch_field(plot_opts$errors$show), - lines_toggle = new_switch_field(plot_opts$lines$show) - ) - - new_block( - fields = fields, - expr = quote({ - x_var <- .(x_var) - y_var <- .(y_var) - color <- .(color) - shape <- .(shape) - - data <- data |> - mutate( - ymin = MEAN - SE, - ymax = MEAN + SE, - TOOLTIP = sprintf("x: %s\ny: %s", .data[[x_var]], .data[[y_var]]), - TOOLTIP_SE = sprintf( - "x: %s\ny: %s\nmin: %s\nmax: %s", - .data[[x_var]], .data[[y_var]], - ymin, ymax - ) - ) - - p <- ggplot(data) + - ggiraph::geom_point_interactive( - # We have to use aes_string over aes - mapping = aes( - x = .data[[x_var]], - y = .data[[y_var]], - color = .data[[color]], - shape = .data[[shape]], - tooltip = TOOLTIP - ), - size = 3 # .(point_size) TO DO: allow slide to have 1 value - ) - - # Adding errors - if (.(errors_toggle)) { - p <- p + ggiraph::geom_errorbar_interactive( - aes( - x = .data[[x_var]], - y = .data[[y_var]], - ymin = MEAN - SE, - ymax = MEAN + SE, - color = ACTARM, - tooltip = TOOLTIP_SE - ), - width = 0.2 - ) - } - - if (.(lines_toggle)) { - p <- p + ggiraph::geom_line_interactive( - aes( - x = .data[[x_var]], - y = .data[[y_var]], - group = .data[[color]], - color = .data[[color]] - ) - ) - } - - p <- p + - labs( - title = .(title), - x = .(x_lab), - y = .(y_lab) - ) + - theme( - axis.text.x = element_text(angle = 45, hjust = 1), - legend.title = element_text(face = "bold"), - legend.position = "bottom" - ) + - ggiraph::scale_color_brewer_interactive( - name = "Treatment Group", - palette = "Set1" - ) + - ggiraph::scale_shape_manual_interactive( - name = "Treatment Group", - values = c(16, 17, 18, 19, 20) - ) - - p <- ggiraph::girafe(ggobj = p) - p <- ggiraph::girafe_options( - p, - ggiraph::opts_tooltip( - opacity = .7, - offx = 20, - offy = -10, - use_fill = TRUE, - use_stroke = TRUE, - delay_mouseout = 1000 - ) - ) - }), - ..., - class = c("ggiraph_block", "plot_block", "submit_block") - ) -} - -#' @rdname plot_block -#' @export -ggiraph_block <- function(data, ...) { - initialize_block(new_ggiraph_block(data, ...), data) -} - -#' @rdname plot_block -#' @export -server_output.ggiraph_block <- function(x, result, output) { - renderGirafe(result()) -} - -#' @rdname plot_block -#' @export -uiOutputBlock.ggiraph_block <- function(x, ns) { - girafeOutput(ns("plot")) -} - -#' As factor block -#' -#' Useful for the BMS demo app -#' -#' @inheritParams new_plot_block -#' @param column Column to apply the operation on. -#' @rdname demo_block -#' @export -#' @import blockr -new_asfactor_block <- function(data, column = "VISIT", ...) { - all_cols <- function(data) colnames(data) - - mutate_expr <- function(data, column) { - if (is.null(column)) { - return(NULL) - } - if (!(column %in% colnames(data))) { - return(NULL) - } - - bquote( - dplyr::mutate( - VISIT = factor( - .(column), - levels = unique(.(column)), - ordered = TRUE - ) - ), - list(column = as.name(column)) - ) - } - - fields <- list( - column = new_select_field(column, column), - expression = new_hidden_field(mutate_expr) - ) - - new_block( - fields = fields, - expr = quote(.(expression)), - ..., - class = c("asfactor_block", "transform_block") - ) -} - -#' @rdname demo_block -#' @export -asfactor_block <- function(data, ...) { - initialize_block(new_asfactor_block(data, ...), data) -} - -#' @rdname demo_block -#' @export -lab_data_block <- function(...) { - initialize_block(new_data_block( - ..., - dat = as.environment("package:blockr.data"), - selected = "lab" - )) -} - -#' @rdname demo_block -#' @export -demo_data_block <- function(...) { - initialize_block(new_data_block( - ..., - dat = as.environment("package:blockr.data"), - selected = "demo" - )) -} - -#' @rdname demo_block -#' @export -demo_join_block <- function(data, ...) { - blk <- initialize_block( - new_join_block( - data, - type = "inner", - by = c("STUDYID", "USUBJID"), - ... - ), - data - ) - class(blk) <- class(blk)[-3] - blk$submit <- NULL - blk -} - -#' @rdname demo_block -#' @export -demo_arrange_block <- function(data, ...) { - arrange_block( - data, - columns = "VISITNUM", - ... - ) -} - -#' @rdname demo_block -#' @export -demo_group_by_block <- function(data, ...) { - group_by_block( - data, - columns = c("VISIT", "ACTARM"), - ... - ) -} - -#' @rdname demo_block -#' @export -demo_filter_block_1 <- function(data, ...) { - blk <- initialize_block( - new_filter_block( - data, - columns = "LBTEST", - values = "Hemoglobin", - ... - ), - data - ) - class(blk) <- class(blk)[-3] - blk$submit <- NULL - blk -} - -#' @rdname demo_block -#' @export -demo_filter_block_2 <- function(data, ...) { - blk <- initialize_block( - new_filter_block( - data, - columns = "VISIT", - values = "UNSCHEDULED", - filter_fun = "!startsWith", - ... - ), - data - ) - class(blk) <- class(blk)[-3] - blk$submit <- NULL - blk -} - -#' @rdname demo_block -#' @export -demo_summarize_block <- function(data, ...) { - blk <- initialize_block( - new_summarize_block( - data, - default_columns = c("LBSTRESN", "LBSTRESN"), - ... - ), - data - ) - class(blk) <- class(blk)[-3] - blk$submit <- NULL - blk -} diff --git a/R/utils.R b/R/utils.R index 28ecf7e..00b5048 100644 --- a/R/utils.R +++ b/R/utils.R @@ -35,23 +35,11 @@ ui_fields_one_column <- function(x, ns, inputs_hidden) { register_blockr_extra_blocks <- function(pkg) { - if (missing(pkg)) { - pkg <- pkg_name() - } + if (missing(pkg)) + pkg <- "blockr.extra" register_blocks( constructor = c( - plot_block, - ggiraph_block, - asfactor_block, - lab_data_block, - demo_data_block, - demo_join_block, - demo_arrange_block, - demo_group_by_block, - demo_filter_block_1, - demo_filter_block_2, - demo_summarize_block, admiral_dpc_block, filter_expr_block, summarize_expr_block, @@ -59,17 +47,6 @@ register_blockr_extra_blocks <- function(pkg) { code_plot_block ), name = c( - "plot block", - "ggiraph block", - "asfactor block", - "lab data_block", - "demo data block", - "demo join block", - "demo arrange block", - "demo group by block", - "demo filter block 1", - "demo filter block 2", - "demo summarize block", "admiral dpc block", "filter expr block", "summarize expr block", @@ -77,17 +54,6 @@ register_blockr_extra_blocks <- function(pkg) { "code plot block" ), description = c( - "Monolithic ggplot block", - "Monolithic ggiraph block", - "As factor mutate block", - "blockr.data preselected to lab data", - "blockr.data preselected to demo data", - "Predefined join block for BMS demo", - "Predefined arrange block for BMS demo", - "Predefined group by block for BMS demo", - "Predefined filter block for BMS demo 1", - "Predefined filter block for BMS demo 2", - "Predefined summarize block for BMS demo", "Admiral block", "Filter expr block", "Summarize expr block", @@ -95,17 +61,6 @@ register_blockr_extra_blocks <- function(pkg) { "Code plot block" ), classes = list( - c("plot_block", "submit_block"), - c("ggiraph_block", "plot_block", "submit_block"), - c("asfactor_block", "transform_block"), - c("lab_dataset_block", "data_block"), - c("demo_dataset_block", "data_block"), - c("demo_join_block", "transform_block", "submit_block"), - c("demo_arrange_block", "transform_block"), - c("demo_group_by_block", "transform_block"), - c("demo_filter_block_1", "transform_block", "submit_block"), - c("demo_filter_block_2", "transform_block", "submit_block"), - c("demo_summarize_block", "transform_block", "submit_block"), c("admiral_dpc_block", "transform_block"), c("filter_expr_block", "transform_block"), c("summarize_expr_block", "transform_block"), @@ -113,35 +68,13 @@ register_blockr_extra_blocks <- function(pkg) { c("code_plot_block", "plot_block", "submit_block") ), input = c( - "data.frame", - "data.frame", - "data.frame", - NA_character_, NA_character_, "data.frame", "data.frame", "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", "data.frame" ), output = c( - "list", - "list", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", - "data.frame", "data.frame", "data.frame", "data.frame", diff --git a/man/demo_block.Rd b/man/demo_block.Rd deleted file mode 100644 index c8deed4..0000000 --- a/man/demo_block.Rd +++ /dev/null @@ -1,42 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/demo-bms-blocks.R -\name{new_asfactor_block} -\alias{new_asfactor_block} -\alias{asfactor_block} -\alias{demo_data_block} -\alias{demo_join_block} -\alias{demo_arrange_block} -\alias{demo_group_by_block} -\alias{demo_filter_block_1} -\alias{demo_filter_block_2} -\alias{demo_summarize_block} -\title{As factor block} -\usage{ -new_asfactor_block(data, column = "VISIT", ...) - -asfactor_block(data, ...) - -demo_data_block(...) - -demo_join_block(data, ...) - -demo_arrange_block(data, ...) - -demo_group_by_block(data, ...) - -demo_filter_block_1(data, ...) - -demo_filter_block_2(data, ...) - -demo_summarize_block(data, ...) -} -\arguments{ -\item{data}{Tabular data in which to select some columns.} - -\item{column}{Column to apply the operation on.} - -\item{...}{Any other params. TO DO} -} -\description{ -Useful for the BMS demo app -} diff --git a/man/plot_block.Rd b/man/plot_block.Rd deleted file mode 100644 index 648094c..0000000 --- a/man/plot_block.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/demo-bms-blocks.R -\name{new_plot_block} -\alias{new_plot_block} -\alias{plot_block} -\alias{new_ggiraph_block} -\alias{ggiraph_block} -\alias{server_output.ggiraph_block} -\alias{uiOutputBlock.ggiraph_block} -\title{Monolithic ggplot block} -\usage{ -new_plot_block( - data, - plot_opts = list(colors = c("blue", "red"), point_size = 3, title = "Plot title", theme - = c("theme_minimal", "theme_gray", "theme_linedraw", "theme_dark", "theme_light", - "theme_classic", "theme_void", "theme_bw"), x_lab = "X axis label", y_lab = - "Y axis label", errors = list(show = FALSE, ymin = character(), ymax = character()), - lines = list(show = FALSE, group = character(), color = character())), - ... -) - -plot_block(data, ...) - -new_ggiraph_block( - data, - plot_opts = list(colors = c("blue", "red"), point_size = 3, title = "Plot title", theme - = c("theme_minimal", "theme_gray", "theme_linedraw", "theme_dark", "theme_light", - "theme_classic", "theme_void", "theme_bw"), x_lab = "X axis label", y_lab = - "Y axis label", errors = list(show = TRUE, ymin = character(), ymax = character()), - lines = list(show = TRUE, group = character(), color = character())), - ... -) - -ggiraph_block(data, ...) - -\method{server_output}{ggiraph_block}(x, result, output) - -\method{uiOutputBlock}{ggiraph_block}(x, ns) -} -\arguments{ -\item{data}{Tabular data in which to select some columns.} - -\item{plot_opts}{List containing options for ggplot (color, ...).} - -\item{...}{Any other params. TO DO} - -\item{x}{Object for which to generate UI components} - -\item{result}{Block result} - -\item{output}{Shiny output} - -\item{ns}{Output namespace} -} -\description{ -Used with cdisc data. See \link{demo_data_block}. - -To use with \link{demo_data_block} as data input. -}