[Discussion]: Discuss with SME team the concept of module decoration

[gogonzo]

part of #1384

Improved POC

In response to the conclusions from the last meeting we implemented a slightly different design.

1. decorators specified for tm_ constructor should be a list of teal_transform_module.

2. There is a way to simplify building of teal_transform_module's server by calling make_teal_transform_server(expr). This function allows to simply write an expression which will be wrapped in necessary boilerplate shiny-server code. When expression contains a name which matches the input, then it will be substituted with input value. Consider following, where ui has input named gg_title and in the expression there is ggtitle(gg_title). This would result in gg_title to be replaced with input$gg_title value.

   simplified server constructor

   teal_transform_module(
     ui = function(id) {
       ns <- NS(id)
       textInput(ns("gg_title"), ...)
     },
     server = make_teal_transform_server(expression(graph <- graph + ggtitle(gg_title)))
   )

3. When created teal_transform_module has constant object names. This means that it is hard to robustly reuse
   transformer in any tm_ module. It is recomended for external parties to collect library of "decorators" as functions
   to potentially adjust the content of the evaluated expression to teal_modules's internals. See the following example
   and focus on output_name.

   function constructor

   gg_xlab_decorator <- function(output_name) {
     teal_transform_module(
       ui = function(id) {
         ns <- NS(id)
         div(
           textInput(ns("x_axis_title"), "X axis title", value = "x axis")
         )
       },
       server = function(id, data) {
         moduleServer(id, function(input, output, session) {
           reactive({
             req(data())
             data() |> within(
               {
                 output_name <- output_name +
                   xlab(x_axis_title)
               },
               x_axis_title = input$x_axis_title,
               output_name = as.name(output_name)
             )
           })
         })
       }
     )
   }

example app

pkgload::load_all("teal")

static_decorator <- teal_transform_module(
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      reactive({
        req(data())
        data() |> within({
          plot <- plot +
            ggtitle("This is title") +
            xlab("x axis")
        })
      })
    })
  }
)

static_decorator_lang <- teal_transform_module(
  server = make_teal_transform_server(
    expression(
      plot <- plot +
        ggtitle("This is title") +
        xlab("x axis title")
    )
  )
)

interactive_decorator <- teal_transform_module(
  ui = function(id) {
    ns <- NS(id)
    div(
      textInput(ns("x_axis_title"), "X axis title", value = "x axis")
    )
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      reactive({
        req(data())
        data() |> within(
          {
            plot <- plot +
              ggtitle("This is title") +
              xlab(x_axis_title)
          },
          x_axis_title = input$x_axis_title
        )
      })
    })
  }
)

interactive_decorator_lang <- teal_transform_module(
  ui = function(id) {
    ns <- NS(id)
    div(
      textInput(ns("x_axis_title"), "X axis title", value = "x axis")
    )
  },
  server = make_teal_transform_server(
    expression(
      plot <- plot +
        ggtitle("This is title") +
        xlab(x_axis_title)
    )
  )
)

gg_xlab_decorator <- function(output_name) {
  teal_transform_module(
    ui = function(id) {
      ns <- NS(id)
      div(
        textInput(ns("x_axis_title"), "X axis title", value = "x axis")
      )
    },
    server = function(id, data) {
      moduleServer(id, function(input, output, session) {
        reactive({
          req(data())
          data() |> within(
            {
              output_name <- output_name +
                xlab(x_axis_title)
            },
            x_axis_title = input$x_axis_title,
            output_name = as.name(output_name)
          )
        })
      })
    }
  )
}

failing_decorator <- teal_transform_module(
  ui = function(id) {
    ns <- NS(id)
    div(
      textInput(ns("x_axis_title"), "X axis title", value = "x axis")
    )
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      reactive(stop("Hihi"))
    })
  }
)

tm_decorated_plot <- function(label = "module", transforms = list(), decorators = teal_transform_module()) {
  module(
    label = label,
    ui = function(id, decorators) {
      ns <- NS(id)
      div(
        selectInput(ns("dataname"), label = "select dataname", choices = NULL),
        selectInput(ns("x"), label = "select x", choices = NULL),
        selectInput(ns("y"), label = "select y", choices = NULL),
        ui_teal_transform_module(ns("decorate"), transforms = decorators),
        plotOutput(ns("plot")),
        verbatimTextOutput(ns("text"))
      )
    },
    server = function(id, data, decorators) {
      moduleServer(id, function(input, output, session) {
        observeEvent(data(), {
          updateSelectInput(inputId = "dataname", choices = teal.data::datanames(data()))
        })

        observeEvent(input$dataname, {
          updateSelectInput(inputId = "x", choices = colnames(data()[[input$dataname]]))
          updateSelectInput(inputId = "y", label = "select y", choices = colnames(data()[[input$dataname]]))
        })

        q1 <- reactive({
          req(input$dataname, input$x, input$y)
          data() |>
            within(
              {
                plot <- ggplot2::ggplot(dataname, ggplot2::aes(x = x, y = y)) +
                  ggplot2::geom_point()
              },
              dataname = as.name(input$dataname),
              x = as.name(input$x),
              y = as.name(input$y)
            )
        })

        q2 <- srv_teal_transform_module("decorate", data = q1, transforms = decorators)

        plot_r <- reactive({
          req(q2())
          q2()[["plot"]]
        })

        output$plot <- renderPlot(plot_r())
        output$text <- renderText({
          teal.code::get_code(q2())
        })
      })
    },
    ui_args = list(decorators = decorators),
    server_args = list(decorators = decorators)
  )
}

library(ggplot2)
app <- init(
  data = teal_data(iris = iris, mtcars = mtcars),
  modules = modules(
    tm_decorated_plot("identity"),
    tm_decorated_plot("no-ui", decorator = static_decorator),
    tm_decorated_plot("lang", decorator = static_decorator_lang),
    tm_decorated_plot("interactive", decorator = interactive_decorator),
    tm_decorated_plot("interactive-from lang", decorator = interactive_decorator_lang),
    tm_decorated_plot("from-fun", decorator = gg_xlab_decorator("plot")),
    tm_decorated_plot("failing", decorator = failing_decorator)
  )
)

shinyApp(app$ui, app$server)

Example tmg app

pkgload::load_all("teal")
pkgload::load_all("teal.modules.general")
library(teal.widgets)

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

footnote_decorator <- teal_transform_module(
  label = "Footnote",
  ui = function(id) {
    ns <- NS(id)
    div(
      textInput(ns("footnote"), "Footnote", value = "Collaboration")
    )
  },
  server = function(id, data) {
    moduleServer(id, function(input, output, session) {
      reactive({
        req(data())
        within(
          data(),
          g <- g + labs(caption = footnote),
          footnote = input$footnote
        )
      })
    })
  }
)

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

app <- init(
  data = data,
  modules = modules(
    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
        )
      ),
      ggplot2_args = ggplot2_args(
        labs = list(subtitle = "Plot generated by Regression Module")
      ),
      decorator = list(default = footnote_decorator)
    ),
    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
          )
        )
      ),
      boxplot_decorator = footnote_decorator,
      density_decorator = footnote_decorator,
      ggplot2_args = list(
        ggplot2_args(
          labs = list(subtitle = "Plot generated by Outliers Module")
        )
      )
    )
  )
)

shinyApp(app$ui, app$server)

Regression footnote

pkgload::load_all("teal")
pkgload::load_all("teal.modules.general")
library(teal.widgets)

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

# footnote based on the `fit`
footnote_regression <- teal_transform_module(
  server = make_teal_transform_server(expression(
    g <- g + labs(caption = deparse(summary(fit)[[1]]))
  ))
)

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

app <- init(
  data = data,
  modules = modules(
    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
        )
      ),
      ggplot2_args = ggplot2_args(
        labs = list(subtitle = "Plot generated by Regression Module")
      ),
      decorators = list(footnote_regression)
    )
  )
)

shinyApp(app$ui, app$server)

---

Design challenges:

• transforms and decorators they are very similar concepts. transforms modify module's data input while decorators modify module's output object. module function has transforms argument, which is attached to the teal_module object and executed by teal before teal_module's server is called. We would like to document decorators also, but decorators fits better as ui/server_args and thus they don't have a dedicated place in the module() formals. Just consider a module which is defined as follows:
  • ui is a function of id and additional args (ui_args)
  • server is a function if id, data and additional args (server_args)
    If we decide to feed a ui and server with decorators as a separate module() argument it means it goes beyond the definition.

[donyunardi]

The discussion with the SME has been completed, and no further updates are needed. Closing the issue.