Skip to content

Commit

Permalink
🗃️ decorators feature branch (#795)
Browse files Browse the repository at this point in the history 
Partner to insightsengineering/teal#1357
Introduces decorators to modules. More about decorators in here
insightsengineering/teal#1384

<details><summary>Example with 1 tab per module</summary>

```r
pkgload::load_all("../teal")
pkgload::load_all(".")

# ######################################################
#
#   _____                           _
#  |  __ \                         | |
#  | |  | | ___  ___ ___  _ __ __ _| |_ ___  _ __ ___
#  | |  | |/ _ \/ __/ _ \| '__/ _` | __/ _ \| '__/ __|
#  | |__| |  __/ (_| (_) | | | (_| | || (_) | |  \__ \
#  |_____/ \___|\___\___/|_|  \__,_|\__\___/|_|  |___/
#
#
#
#  Decorators
# #####################################################

plot_grob_decorator <- function(default_footnote = "I am a good decorator", .var_to_replace = "plot") {
  teal_transform_module(
    label = "Caption (grob)",
    ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_footnote),
    server = function(id, data) {
      moduleServer(id, function(input, output, session) {
        logger::log_info("🟠 plot_grob with default: {default_footnote}!", namespace = "teal.modules.general")
        reactive({
          req(data(), input$footnote)
          logger::log_info("changing the footnote {default_footnote}", namespace = "teal.modules.general")
          teal.code::eval_code(data(), substitute(
            {
              footnote_grob <- grid::textGrob(footnote, x = 0, hjust = 0, gp = grid::gpar(fontsize = 10, fontface = "italic", col = "gray50"))
              # Arrange the plot and footnote
              .var_to_replace <- gridExtra::arrangeGrob(
                .var_to_replace,
                footnote_grob,
                ncol = 1,
                heights = grid::unit.c(grid::unit(1, "npc") - grid::unit(1, "lines"), grid::unit(1, "lines"))
              )
            },
            env = list(
              footnote = input$footnote,
              .var_to_replace = as.name(.var_to_replace)
            )))
        })
      })
    }
  )
}
caption_decorator <- function(default_caption = "I am a good decorator", .var_to_replace = "plot") {
  teal_transform_module(
    label = "Caption",
    ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_caption),
    server = make_teal_transform_server(
      substitute({
        my_name <- .var_name
        .var_to_replace <- .var_to_replace + ggplot2::labs(caption = footnote)
      }, env = list(.var_to_replace = as.name(.var_to_replace), .var_name = .var_to_replace))
    )
  )
}
table_decorator <- function(.color1 = "#f9f9f9", .color2 = "#f0f0f0", .var_to_replace = "table") {
  teal_transform_module(
    label = "Table color",
    ui = function(id) {
      selectInput(
        NS(id, "style"),
        "Table Style",
        choices = c("Default", "Color1", "Color2"),
        selected = "Default"
      )
    },
    server = function(id, data) {
      moduleServer(id, function(input, output, session) {
        logger::log_info("🔵 Table row color called to action!", namespace = "teal.modules.general")
        reactive({
          req(data(), input$style)
          logger::log_info("changing the Table row color '{input$style}'", namespace = "teal.modules.general")
          teal.code::eval_code(data(), substitute({
            .var_to_replace <- switch(
              style,
              "Color1" = DT::formatStyle(
                .var_to_replace,
                columns = attr(.var_to_replace$x, "colnames")[-1],
                target = "row",
                backgroundColor = .color1
              ),
              "Color2" = DT::formatStyle(
                .var_to_replace,
                columns = attr(.var_to_replace$x, "colnames")[-1],
                target = "row",
                backgroundColor = .color2
              ),
              .var_to_replace
            )
          }, env = list(
            style = input$style,
            .var_to_replace = as.name(.var_to_replace),
            .color1 = .color1,
            .color2 = .color2
          )))
        })
      })
    }
  )
}
head_decorator <- function(default_value = 6, .var_to_replace = "object") {
  teal_transform_module(
    label = "Head",
    ui = function(id) shiny::numericInput(shiny::NS(id, "n"), "Footnote", value = default_value),
    server = make_teal_transform_server(
      substitute({
        .var_to_replace <- utils::head(.var_to_replace, n = n)
      }, env = list(.var_to_replace = as.name(.var_to_replace)))
    )
  )
}
treelis_subtitle_decorator <- function(default_caption = "I am a good decorator", .var_to_replace = "plot") {
  teal_transform_module(
    label = "Caption",
    ui = function(id) shiny::textInput(shiny::NS(id, "footnote"), "Footnote", value = default_caption),
    server = make_teal_transform_server(
      substitute({
        .var_to_replace <- update(.var_to_replace, sub = footnote)
      }, env = list(.var_to_replace = as.name(.var_to_replace)))
    )
  )
}
insert_rrow_decorator <- function(default_caption = "I am a good new row", .var_to_replace = "table") {
  teal_transform_module(
    label = "New row",
    ui = function(id) shiny::textInput(shiny::NS(id, "new_row"), "New row", value = default_caption),
    server = make_teal_transform_server(
      substitute({
        .var_to_replace <- rtables::insert_rrow(.var_to_replace, rtables::rrow(new_row))
      }, env = list(.var_to_replace = as.name(.var_to_replace)))
    )
  )
}
do_nothing_decorator <- teal_transform_module(server = function(id, data) moduleServer(id, function(input, output, session) data))

# ##########################################
#
#   _             _      _       _
#  | |           | |    | |     | |
#  | |_ ___  __ _| |  __| | __ _| |_ __ _
#  | __/ _ \/ _` | | / _` |/ _` | __/ _` |
#  | ||  __/ (_| | || (_| | (_| | || (_| |
#   \__\___|\__,_|_| \__,_|\__,_|\__\__,_|
#                ______
#               |______|
#
#  teal_data
# #########################################

data <- teal_data(join_keys = default_cdisc_join_keys[c("ADSL", "ADRS")])
data <- within(data, {
  require(nestcolor)
  ADSL <- rADSL
  ADRS <- rADRS
})

# For tm_outliers
fact_vars_adsl <- names(Filter(isTRUE, sapply(data[["ADSL"]], is.factor)))
vars <- choices_selected(variable_choices(data[["ADSL"]], fact_vars_adsl))

# For tm_g_distribution

vars1 <- choices_selected(
  variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")),
  selected = NULL
)


init(
  data = data,
  modules = modules(
    # ###################################################
    #
    #                                    _
    #                                   (_)
    #   _ __ ___  __ _ _ __ ___  ___ ___ _  ___  _ __
    #  | '__/ _ \/ _` | '__/ _ \/ __/ __| |/ _ \| '_ \
    #  | | |  __/ (_| | | |  __/\__ \__ \ | (_) | | | |
    #  |_|  \___|\__, |_|  \___||___/___/_|\___/|_| |_|
    #             __/ |
    #            |___/
    #
    #  regression
    # ##################################################
    tm_a_regression(
      label = "Regression",
      response = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          label = "Select variable:",
          choices = "BMRKR1",
          selected = "BMRKR1",
          multiple = FALSE,
          fixed = TRUE
        )
      ),
      regressor = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          label = "Select variables:",
          choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")),
          selected = "AGE",
          multiple = TRUE,
          fixed = FALSE
        )
      ),
      decorators = list(caption_decorator("I am Regression", "plot"))
    ),
    # #########################################################
    #
    #       _ _     _        _ _           _   _
    #      | (_)   | |      (_) |         | | (_)
    #    __| |_ ___| |_ _ __ _| |__  _   _| |_ _  ___  _ __
    #   / _` | / __| __| '__| | '_ \| | | | __| |/ _ \| '_ \
    #  | (_| | \__ \ |_| |  | | |_) | |_| | |_| | (_) | | | |
    #   \__,_|_|___/\__|_|  |_|_.__/ \__,_|\__|_|\___/|_| |_|
    #
    #
    #
    #  distribution
    # ########################################################
    tm_g_distribution(
      dist_var = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
          selected = "BMRKR1",
          multiple = FALSE,
          fixed = FALSE
        )
      ),
      strata_var = data_extract_spec(
        dataname = "ADSL",
        filter = filter_spec(
          vars = vars1,
          multiple = TRUE
        )
      ),
      group_var = data_extract_spec(
        dataname = "ADSL",
        filter = filter_spec(
          vars = vars1,
          multiple = TRUE
        )
      ),
      decorators = list(
        histogram_plot = caption_decorator("I am density!", "histogram_plot"),
        qq_plot = caption_decorator("I am QQ!", "qq_plot"),
        summary_table = table_decorator("#FFA500", "#800080", "summary_table"),
        test_table = table_decorator("#2FA000", "#80FF80", "test_table")
      )
    ),
    # ####################
    #
    #
    #
    #   _ __   ___ __ _
    #  | '_ \ / __/ _` |
    #  | |_) | (_| (_| |
    #  | .__/ \___\__,_|
    #  | |
    #  |_|
    #
    #  pca
    # ###################
    tm_a_pca(
      "PCA",
      dat = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY")),
          selected = c("BMRKR1", "AGE")
        )
      ),
      decorators = list(
        elbow_plot = caption_decorator("I am PCA / elbow", "elbow_plot"),
        circle_plot = caption_decorator("I am a PCA / circle", "circle_plot"),
        biplot = caption_decorator("I am a PCA / bipot", "biplot"),
        eigenvector_plot = caption_decorator("I am a PCA / eigenvector", "eigenvector_plot")
      )
    ),
    ######################################
    #
    #               _   _ _
    #              | | | (_)
    #    ___  _   _| |_| |_  ___ _ __ ___
    #   / _ \| | | | __| | |/ _ \ '__/ __|
    #  | (_) | |_| | |_| | |  __/ |  \__ \
    #   \___/ \__,_|\__|_|_|\___|_|  |___/
    #
    #
    #
    #  outliers
    # #####################################
    tm_outliers(
      outlier_var = list(
        data_extract_spec(
          dataname = "ADSL",
          select = select_spec(
            label = "Select variable:",
            choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")),
            selected = "AGE",
            multiple = FALSE,
            fixed = FALSE
          )
        )
      ),
      categorical_var = list(
        data_extract_spec(
          dataname = "ADSL",
          filter = filter_spec(
            vars = vars,
            choices = value_choices(data[["ADSL"]], vars$selected),
            selected = value_choices(data[["ADSL"]], vars$selected),
            multiple = TRUE
          )
        )
      ),
      decorators = list(
        box_plot = caption_decorator("I am a good decorator", "box_plot"),
        density_plot = caption_decorator("I am a good decorator", "density_plot"),
        cumulative_plot = caption_decorator("I am a good decorator", "cumulative_plot"),
        table = table_decorator("#FFA500", "#800080")
      )
    ),
    # #######################################################
    #
    #                            _       _   _
    #                           (_)     | | (_)
    #    __ _ ___ ___  ___   ___ _  __ _| |_ _  ___  _ __
    #   / _` / __/ __|/ _ \ / __| |/ _` | __| |/ _ \| '_ \
    #  | (_| \__ \__ \ (_) | (__| | (_| | |_| | (_) | | | |
    #   \__,_|___/___/\___/ \___|_|\__,_|\__|_|\___/|_| |_|
    #
    #
    #
    #  association
    # ######################################################
    tm_g_association(
      ref = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(
            data[["ADSL"]],
            c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
          ),
          selected = "RACE"
        )
      ),
      vars = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(
            data[["ADSL"]],
            c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2")
          ),
          selected = "BMRKR2",
          multiple = TRUE
        )
      ),
      decorators = list(plot_grob_decorator("I am a good grob (association)"))
    ),
    # ################################################
    #
    #       _       _         _        _     _
    #      | |     | |       | |      | |   | |
    #    __| | __ _| |_ __ _ | |_ __ _| |__ | | ___
    #   / _` |/ _` | __/ _` || __/ _` | '_ \| |/ _ \
    #  | (_| | (_| | || (_| || || (_| | |_) | |  __/
    #   \__,_|\__,_|\__\__,_| \__\__,_|_.__/|_|\___|
    #                     ______
    #                    |______|
    #
    #  data_table
    # ###############################################
    tm_data_table(
      variables_selected = list(
        iris = c("Sepal.Length", "Sepal.Width", "Petal.Length", "Petal.Width", "Species")
      ),
      dt_args = list(caption = "IRIS Table Caption"),
      decorators = list(table_decorator())
    ),
    # ########################################################
    #
    #                                 _        _     _
    #                                | |      | |   | |
    #    ___ _ __ ___  ___ ___ ______| |_ __ _| |__ | | ___
    #   / __| '__/ _ \/ __/ __|______| __/ _` | '_ \| |/ _ \
    #  | (__| | | (_) \__ \__ \      | || (_| | |_) | |  __/
    #   \___|_|  \___/|___/___/       \__\__,_|_.__/|_|\___|
    #
    #
    #
    #  cross-table
    # #######################################################
    tm_t_crosstable(
      label = "Cross Table",
      x = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], subset = function(data) {
            idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt"))
            return(names(data)[idx])
          }),
          selected = "COUNTRY",
          multiple = TRUE,
          ordered = TRUE
        )
      ),
      y = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], subset = function(data) {
            idx <- vapply(data, is.factor, logical(1))
            return(names(data)[idx])
          }),
          selected = "SEX"
        )
      ),
      decorators = list(insert_rrow_decorator("I am a good new row"))
    ),
    # #######################################################################################
    #
    #                 _   _                  _       _                     _        _
    #                | | | |                | |     | |                   | |      (_)
    #   ___  ___ __ _| |_| |_ ___ _ __ _ __ | | ___ | |_   _ __ ___   __ _| |_ _ __ ___  __
    #  / __|/ __/ _` | __| __/ _ \ '__| '_ \| |/ _ \| __| | '_ ` _ \ / _` | __| '__| \ \/ /
    #  \__ \ (_| (_| | |_| ||  __/ |  | |_) | | (_) | |_  | | | | | | (_| | |_| |  | |>  <
    #  |___/\___\__,_|\__|\__\___|_|  | .__/|_|\___/ \__| |_| |_| |_|\__,_|\__|_|  |_/_/\_\
    #                                 | |
    #                                 |_|
    #
    #  scatterplot matrix
    # ######################################################################################
    tm_g_scatterplotmatrix(
      label = "Scatterplot matrix",
      variables = list(
        data_extract_spec(
          dataname = "ADSL",
          select = select_spec(
            choices = variable_choices(data[["ADSL"]]),
            selected = c("AGE", "RACE", "SEX"),
            multiple = TRUE,
            ordered = TRUE
          )
        ),
        data_extract_spec(
          dataname = "ADRS",
          filter = filter_spec(
            label = "Select endpoints:",
            vars = c("PARAMCD", "AVISIT"),
            choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")),
            selected = "INVET - END OF INDUCTION",
            multiple = TRUE
          ),
          select = select_spec(
            choices = variable_choices(data[["ADRS"]]),
            selected = c("AGE", "AVAL", "ADY"),
            multiple = TRUE,
            ordered = TRUE
          )
        )
      ),
      decorators = list(treelis_subtitle_decorator("I am a Scatterplot matrix", "plot"))
    ),
    # #############################################
    #
    #
    #
    #   _ __ ___  ___ _ __   ___  _ __  ___  ___
    #  | '__/ _ \/ __| '_ \ / _ \| '_ \/ __|/ _ \
    #  | | |  __/\__ \ |_) | (_) | | | \__ \  __/
    #  |_|  \___||___/ .__/ \___/|_| |_|___/\___|
    #                | |
    #                |_|
    #
    #  response
    # ############################################
    tm_g_response(
      label = "Response",
      response = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")))
      ),
      x = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")), selected = "RACE")
      ),
      decorators = list(caption_decorator("I am a Response", "plot"))
    ),
    # ############################################
    #
    #   _     _                 _       _
    #  | |   (_)               (_)     | |
    #  | |__  ___   ____ _ _ __ _  __ _| |_ ___
    #  | '_ \| \ \ / / _` | '__| |/ _` | __/ _ \
    #  | |_) | |\ V / (_| | |  | | (_| | ||  __/
    #  |_.__/|_| \_/ \__,_|_|  |_|\__,_|\__\___|
    #
    #
    #
    #  bivariate
    # ###########################################
    tm_g_bivariate(
      x = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]]), selected = "AGE")
      ),
      y = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]]), selected = "SEX")
      ),
      row_facet = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]]), selected = "ARM")
      ),
      col_facet = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]]), selected = "COUNTRY")
      ),
      decorators = list(caption_decorator("I am a Bivariate", "plot"))
    ),
    #####################################################
    #
    #                 _   _                  _       _
    #                | | | |                | |     | |
    #   ___  ___ __ _| |_| |_ ___ _ __ _ __ | | ___ | |_
    #  / __|/ __/ _` | __| __/ _ \ '__| '_ \| |/ _ \| __|
    #  \__ \ (_| (_| | |_| ||  __/ |  | |_) | | (_) | |_
    #  |___/\___\__,_|\__|\__\___|_|  | .__/|_|\___/ \__|
    #                                 | |
    #                                 |_|
    #
    #  scatterplot
    # ####################################################
    tm_g_scatterplot(
      label = "Scatterplot",
      x = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")))
      ),
      y = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")),
          selected = "BMRKR1"
        )
      ),
      color_by = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1")),
          selected = NULL
        )
      ),
      size_by = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")))
      ),
      row_facet = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
          selected = NULL
        )
      ),
      col_facet = data_extract_spec(
        dataname = "ADSL",
        select = select_spec(
          choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")),
          selected = NULL
        )
      ),
      decorators = list(caption_decorator("I am a scatterplot", "plot"))
    ),
    # ##############################################################
    #
    #             _         _                    _       _
    #            (_)       (_)                  | |     | |
    #   _ __ ___  _ ___ ___ _ _ __   __ _     __| | __ _| |_ __ _
    #  | '_ ` _ \| / __/ __| | '_ \ / _` |   / _` |/ _` | __/ _` |
    #  | | | | | | \__ \__ \ | | | | (_| |  | (_| | (_| | || (_| |
    #  |_| |_| |_|_|___/___/_|_| |_|\__, |   \__,_|\__,_|\__\__,_|
    #                                __/ |_____
    #                               |___/______|
    #
    #  missing_data
    # #############################################################
    tm_missing_data(
      label = "Missing data",
      decorators = list(
        summary_plot = plot_grob_decorator("A", "summary_plot"),
        combination_plot = plot_grob_decorator("B", "combination_plot"),
        summary_table = table_decorator("table", .color1 = "#f0000055"),
        by_subject_plot = caption_decorator("by_subject_plot")
      )
    ),
    example_module(decorators = list(head_decorator(6)))
  )
) |> shiny::runApp()
```

---------

Signed-off-by: Marcin <[email protected]>
Signed-off-by: André Veríssimo <[email protected]>
Co-authored-by: go_gonzo <[email protected]>
Co-authored-by: Konrad Pagacz <[email protected]>
Co-authored-by: github-actions <41898282+github-actions[bot]@users.noreply.github.com>
Co-authored-by: 27856297+dependabot-preview[bot]@users.noreply.github.com <27856297+dependabot-preview[bot]@users.noreply.github.com>
Co-authored-by: André Veríssimo <[email protected]>
  • Loading branch information
@m7pr @gogonzo
@kpagacz @github-actions @dependabot-preview @averissimo
6 people authored Nov 29, 2024
1 parent cd8ac9d commit 02f18ab
Show file tree
Hide file tree
Showing 37 changed files with 2,033 additions and 918 deletions.
3 changes: 2 additions & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ Imports:
DT (>= 0.13),
forcats (>= 1.0.0),
grid,
lifecycle (>= 0.2.0),
scales,
shinyjs,
shinyTree (>= 0.2.8),
Expand Down Expand Up @@ -84,7 +85,7 @@ VignetteBuilder:
Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2,
rstudio/shiny, insightsengineering/teal,
insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr,
rstudio/DT, tidyverse/forcats, r-lib/scales, daattali/shinyjs,
rstudio/DT, tidyverse/forcats, r-lib/lifecycle, r-lib/scales, daattali/shinyjs,
shinyTree/shinyTree, rstudio/shinyvalidate, dreamRs/shinyWidgets,
tidyverse/stringr, insightsengineering/teal.code,
insightsengineering/teal.data, insightsengineering/teal.logger,
Expand Down
30 changes: 30 additions & 0 deletions R/roxygen2_templates.R
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,30 @@
# nocov start
roxygen_decorators_param <- function(module_name) {
paste(
sep = " ",
lifecycle::badge("experimental"),
" (`list` of `teal_transform_module`, named `list` of `teal_transform_module` or",
"`NULL`) optional, if not `NULL`, decorator for tables or plots included in the module.",
"When a named list of `teal_transform_module`, the decorators are applied to the",
"respective output objects.\n\n",
"Otherwise, the decorators are applied to all objects, which is equivalent as using the name `default`.\n\n",
sprintf("See section \"Decorating `%s`\"", module_name),
"below for more details."
)
}

roxygen_ggplot2_args_param <- function(...) {
paste(
sep = " ",
"(`ggplot2_args`) optional, object created by [`teal.widgets::ggplot2_args()`]",
"with settings for all the plots or named list of `ggplot2_args` objects for plot-specific settings.",
"The argument is merged with options variable `teal.ggplot2_args` and default module setup.\n\n",
sprintf(
"List names should match the following: `c(\"default\", %s)`.\n\n",
paste("\"", unlist(rlang::list2(...)), "\"", collapse = ", ", sep = "")
),
"For more details see the vignette: `vignette(\"custom-ggplot2-arguments\", package = \"teal.widgets\")`."
)
}

# nocov end
151 changes: 120 additions & 31 deletions R/tm_a_pca.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -13,16 +13,46 @@
#' It controls the font size for plot titles, axis labels, and legends.
#' - If vector of `length == 1` then the font sizes will have a fixed size.
#' - while vector of `value`, `min`, and `max` allows dynamic adjustment.
#' @templateVar ggnames "Elbow plot", "Circle plot", "Biplot", "Eigenvector plot"
#' @template ggplot2_args_multi
#' @param ggplot2_args `r roxygen_ggplot2_args_param("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot")`
#' @param decorators `r roxygen_decorators_param("tm_a_pca")`
#'
#' @inherit shared_params return
#'
#' @section Decorating `tm_a_pca`:
#'
#' This module generates the following objects, which can be modified in place using decorators:
#' - `elbow_plot` (`ggplot2`)
#' - `circle_plot` (`ggplot2`)
#' - `biplot` (`ggplot2`)
#' - `eigenvector_plot` (`ggplot2`)
#'
#' Decorators can be applied to all outputs or only to specific objects using a
#' named list of `teal_transform_module` objects.
#' The `"default"` name is reserved for decorators that are applied to all outputs.
#' See code snippet below:
#'
#' ```
#' tm_a_pca(
#' ..., # arguments for module
#' decorators = list(
#' default = list(teal_transform_module(...)), # applied to all outputs
#' elbow_plot = list(teal_transform_module(...)), # applied only to `elbow_plot` output
#' circle_plot = list(teal_transform_module(...)) # applied only to `circle_plot` output
#' biplot = list(teal_transform_module(...)) # applied only to `biplot` output
#' eigenvector_plot = list(teal_transform_module(...)) # applied only to `eigenvector_plot` output
#' )
#' )
#' ```
#'
#' For additional details and examples of decorators, refer to the vignette
#' `vignette("decorate-modules-output", package = "teal")` or the [`teal_transform_module()`] documentation.
#'
#' @examplesShinylive
#' library(teal.modules.general)
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # general data example
#' data <- teal_data()
#' data <- within(data, {
Expand Down Expand Up @@ -58,6 +88,7 @@
#' interactive <- function() TRUE
#' {{ next_example }}
#' @examples
#'
#' # CDISC data example
#' data <- teal_data()
#' data <- within(data, {
Expand Down Expand Up @@ -102,7 +133,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
alpha = c(1, 0, 1),
size = c(2, 1, 8),
pre_output = NULL,
post_output = NULL) {
post_output = NULL,
decorators = NULL) {
message("Initializing tm_a_pca")

# Normalize the parameters
Expand Down Expand Up @@ -152,6 +184,10 @@ tm_a_pca <- function(label = "Principal Component Analysis",

checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)
checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE)

available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot")
decorators <- normalize_decorators(decorators)
assert_decorators(decorators, null.ok = TRUE, available_decorators)
# End of assertions

# Make UI args
Expand All @@ -169,7 +205,8 @@ tm_a_pca <- function(label = "Principal Component Analysis",
list(
plot_height = plot_height,
plot_width = plot_width,
ggplot2_args = ggplot2_args
ggplot2_args = ggplot2_args,
decorators = decorators
)
),
datanames = teal.transform::get_extract_datanames(data_extract_list)
Expand Down Expand Up @@ -224,6 +261,34 @@ ui_a_pca <- function(id, ...) {
label = "Plot type",
choices = args$plot_choices,
selected = args$plot_choices[1]
),
conditionalPanel(
condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")),
ui_decorate_teal_data(
ns("d_elbow_plot"),
decorators = select_decorators(args$decorators, "elbow_plot")
)
),
conditionalPanel(
condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")),
ui_decorate_teal_data(
ns("d_circle_plot"),
decorators = select_decorators(args$decorators, "circle_plot")
)
),
conditionalPanel(
condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")),
ui_decorate_teal_data(
ns("d_biplot"),
decorators = select_decorators(args$decorators, "biplot")
)
),
conditionalPanel(
condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")),
ui_decorate_teal_data(
ns("d_eigenvector_plot"),
decorators = select_decorators(args$decorators, "eigenvector_plot")
)
)
),
teal.widgets::panel_item(
Expand Down Expand Up @@ -289,7 +354,7 @@ ui_a_pca <- function(id, ...) {
}

# Server function for the PCA module
srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args) {
srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, plot_width, ggplot2_args, decorators) {
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI")
checkmate::assert_class(data, "reactive")
Expand Down Expand Up @@ -549,7 +614,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)

cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3]
g <- ggplot(mapping = aes_string(x = "component", y = "value")) +
elbow_plot <- ggplot(mapping = aes_string(x = "component", y = "value")) +
geom_bar(
aes(fill = "Single variance"),
data = dplyr::filter(elb_dat, metric == "Proportion of Variance"),
Expand All @@ -569,8 +634,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) +
ggthemes +
themes

print(g)
},
env = list(
ggthemes = parsed_ggplot2_args$ggtheme,
Expand Down Expand Up @@ -628,7 +691,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
y = sin(seq(0, 2 * pi, length.out = 100))
)

g <- ggplot(pca_rot) +
circle_plot <- ggplot(pca_rot) +
geom_point(aes_string(x = x_axis, y = y_axis)) +
geom_label(
aes_string(x = x_axis, y = y_axis, label = "label"),
Expand All @@ -640,7 +703,6 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
labs +
ggthemes +
themes
print(g)
},
env = list(
x_axis = x_axis,
Expand Down Expand Up @@ -861,8 +923,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
qenv,
substitute(
expr = {
g <- plot_call
print(g)
biplot <- plot_call
},
env = list(
plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr)
Expand All @@ -871,8 +932,8 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
}

# plot pc_var ----
plot_pc_var <- function(base_q) {
# plot eigenvector_plot ----
plot_eigenvector <- function(base_q) {
pc <- input$pc
ggtheme <- input$ggtheme

Expand Down Expand Up @@ -938,10 +999,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
expr = {
pca_rot <- pca$rotation[, pc, drop = FALSE] %>%
dplyr::as_tibble(rownames = "Variable")

g <- plot_call

print(g)
eigenvector_plot <- plot_call
},
env = list(
pc = pc,
Expand All @@ -951,23 +1009,54 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
)
}

# plot final ----
output_q <- reactive({
req(computation())
teal::validate_inputs(iv_r())
teal::validate_inputs(iv_extra, header = "Plot settings are required")
# qenvs ---
output_q <- lapply(
list(
elbow_plot = plot_elbow,
circle_plot = plot_circle,
biplot = plot_biplot,
eigenvector_plot = plot_eigenvector
),
function(fun) {
reactive({
req(computation())
teal::validate_inputs(iv_r())
teal::validate_inputs(iv_extra, header = "Plot settings are required")
fun(computation())
})
}
)

switch(input$plot_type,
"Elbow plot" = plot_elbow(computation()),
"Circle plot" = plot_circle(computation()),
"Biplot" = plot_biplot(computation()),
"Eigenvector plot" = plot_pc_var(computation()),
decorated_q <- mapply(
function(obj_name, q) {
srv_decorate_teal_data(
id = sprintf("d_%s", obj_name),
data = q,
decorators = select_decorators(decorators, obj_name),
expr = reactive({
substitute(print(.plot), env = list(.plot = as.name(obj_name)))
}),
expr_is_reactive = TRUE
)
},
names(output_q),
output_q
)

# plot final ----
decorated_output_q <- reactive({
switch(req(input$plot_type),
"Elbow plot" = decorated_q$elbow_plot(),
"Circle plot" = decorated_q$circle_plot(),
"Biplot" = decorated_q$biplot(),
"Eigenvector plot" = decorated_q$eigenvector_plot(),
stop("Unknown plot")
)
})

plot_r <- reactive({
output_q()[["g"]]
plot_name <- gsub(" ", "_", tolower(req(input$plot_type)))
req(decorated_output_q())[[plot_name]]
})

pws <- teal.widgets::plot_with_settings_srv(
Expand Down Expand Up @@ -1034,7 +1123,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl

teal.widgets::verbatim_popup_srv(
id = "rcode",
verbatim_content = reactive(teal.code::get_code(output_q())),
verbatim_content = reactive(teal.code::get_code(req(decorated_output_q()))),
title = "R Code for PCA"
)

Expand All @@ -1057,7 +1146,7 @@ srv_a_pca <- function(id, data, reporter, filter_panel_api, dat, plot_height, pl
card$append_text("Comment", "header3")
card$append_text(comment)
}
card$append_src(teal.code::get_code(output_q()))
card$append_src(teal.code::get_code(req(decorated_output_q())))
card
}
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
Expand Down
Loading

0 comments on commit 02f18ab

Please sign in to comment.