Mwavu
Mwavu

Mwavu

Return User Input Values From Modules

Photo by Zdeněk Macháček on Unsplash

Return User Input Values From Modules

Mwavu's photo
Mwavu
·Mar 26, 2022·

10 min read

In this series:

  • The first article gave you an idea of what R shiny modules are and guided you in creating your first working module.

  • The second article showed you how to treat modules like normal R functions, with multiple arguments & a return value.

  • This third (and final article in the series) will cover how to return any user input value from a module so that another module can use it. We'll also do some final touches on our application to improve UI/UX.

Hold on a second, did I just forget to give my usual pep talk at the start of an article? Naah, it's not growth. Let's call a spade a spade, it's forgetting. Forgetting that it's the little things that matter...

"Like the small modules we build to make up the larger shiny application?" You ask.

"Yes, son"

Pep Talk

I'm not a dating coach but I know one thing for sure...

image.png

How you use that information is entirely up to you. 🌚

The Third Tab, Distributions

What are our objectives?

  • Take variables selected in the second tab and,

  • Plot their distributions.

Basically there's nothing new here, just solidifying what we learnt in part 1 & 2. Let's get right into it.

Take variables selected in the second tab

This means that plot_server() should return the user choices of the inputs x_var and y_var.

When returning more than one element I always find it easier to:

  1. Return a wrapper/container reactive which,

  2. Contains a list of reactives (the elements)

This is what I mean:

reactive({
  list(
    a = reactive({
      # ...
    }), 

    b = reactive({
      # ...
    }), 

    # .
    # .
    # .
  )
})

So let's head to plot_server() and add this:

# ----return----
res <- reactive({
  list(
    x_var = reactive({ input$x_var  }), 
    y_var = reactive({ input$y_var })
  )
})

return(res)

We don't need to return r_flowers data since it is returned by data_input_server() so we'll only return the x and y values.

Our plot_server() should now look like this:

plot_server <- function(id, r_flowers) {
  # Just to be 💯% sure that `r_flowers` is a reactive:
  stopifnot(is.reactive(r_flowers))

  moduleServer(
    id = id,

    module = function(input, output, session) {
      observe({
        # choices will be the numeric cols of `r_flowers()`:
        numeric_cols <- purrr::map_lgl(
          .x = r_flowers(),  # *Note this*
          .f = is.numeric
        )

        choices <- colnames(r_flowers())[numeric_cols]

        # update the `selectInput()`s:
        updateSelectInput(
          session = session,
          inputId = "x_var",
          choices = choices
        )

        updateSelectInput(
          session = session,
          inputId = "y_var",
          choices = choices
        )
      })

      # ----plots----
      plots <- reactive({
        xy_plots(
          flowers = r_flowers(),
          x = input$x_var,
          y = input$y_var
        )
      })

      # x_var vs y_var:
      output$x_vs_y <- renderPlot({
        plots()$scatterplot
      })

      output$x_boxplot <- renderPlot({
        plots()$x_boxplot
      })

      output$y_boxplot <- renderPlot({
        plots()$y_boxplot
      })

      # ----return----
      res <- reactive({
        list(
          x_var = reactive({ input$x_var  }),
          y_var = reactive({ input$y_var })
        )
      })

      return(res)
    }
  )
}

Then go to server.R and capture the returned values:

server <- function(input, output, session) {
  r_flowers <- data_input_server(
    id = "data_input",
    parent_session = session
  )

  xy_vars <- plot_server(
    id = "var_plots",
    r_flowers = r_flowers
  )
}

Now let's build the UI and server parts of the distribution tab.

Module UI

Create a new file in the /R folder and name it distribution_ui.R.

By now I'm sure you have a gist of the flow. It's a function which must take id as one of it's arguments, it preferrably returns a tagList() and all inputId and outputIds are wrapped in NS().

Let's make the tab as simple as it can get. Add this to distribution_ui.R:

distribution_ui <- function(id) {
  shiny::tagList(
    fluidRow(
      align = "center",

      column(
        width = 6,

        # Variable name above plot eg. Sepal Length:
        tags$h3(
          textOutput(
            outputId = NS(namespace = id, id = "x_header")
          )
        ),

        # The plot:
        plotOutput(
          outputId = NS(namespace = id, id = "x_distribution")
        )
      ),

      column(
        width = 6,

        tags$h3(
          textOutput(
            outputId = NS(namespace = id, id = "y_header")
          )
        ),

        plotOutput(
          outputId = NS(namespace = id, id = "y_distribution")
        )
      )
    )
  )
}

Module Server

Create another file under the /R folder and name it distribution_server.R.

Here we just want to render the textOutput()s defined in the module UI correctly, then show the plots.

Let's start with the textOutput()s:

distribution_server <- function(id, xy_vars) {
  stopifnot(is.reactive(xy_vars))

  moduleServer(
    id = id,

    module = function(input, output, session) {
      output$x_header <- renderText({
        xy_vars()$x_var() # *Note this*
      })

      output$y_header <- renderText({
        xy_vars()$y_var() # *Again, Note this*
      })
    }
  )
}

Recall that xy_vars is itself a reactive containing a list of reactives. That should explain why we call it like a function, treat it as a list when subsetting and again call the list elements like functions.

Go to ui.R inside the tabPanel() titled Distributions and call distribution_ui() there with an id. Then go to server.R and call distribution_server() with the same id and pass xy_vars as the second argument.

Run App, choose the iris.csv file then play around with the x and y values and see if the textOutputs() in tab Distributions are being updated.

Did it work?

image.png

Time for the distribution plots.

I'm always so tempted to clump the code for the plots inside the module server but we all know that ends in premium tears.

image.png

So let's create a file inside /R folder and name it hist_density.R. It will contain the plotting function.

Populate it with:

#' Histogram overlaid with kernel density curve.
#'
#' @param flowers dataset to use, of course it *must* be iris in
#' our case
#' @param col_name Length 1 character vector of the column to plot
#'
#' @return `ggplot2` object
#' @export
#'
#' @examples
#' hist_density(iris, "Sepal.Length")
#' hist_density(iris, "Petal.Length")

hist_density <- function(flowers, col_name) {
  flowers |>
  ggplot2::ggplot(
    mapping = ggplot2::aes( x = .data[[col_name]] )
  ) +
    # Histogram with density instead of count on y-axis:
    ggplot2::geom_histogram(
      mapping = ggplot2::aes(y = ..density..),
      binwidth = 0.5,
      colour = "white",
      fill = "orange"
    ) +
    # Overlay with density plot:
    ggplot2::geom_density(color = "#223843") +
    ggplot2::theme_bw()

}

That function will be called inside distribution_server() meaning that the module server requires and extra argument: dataset (r_flowers)

Let's add the argument to distribution_server() and render the plots:

distribution_server <- function(
    id,
    r_flowers,
    xy_vars
  ) {
  stopifnot(is.reactive(r_flowers))
  stopifnot(is.reactive(xy_vars))

  moduleServer(
    id = id,

    module = function(input, output, session) {
      # ----text----
      output$x_header <- renderText({
        xy_vars()$x_var() # *Note this*
      })

      output$y_header <- renderText({
        xy_vars()$y_var() # *Again, Note this*
      })

      # ----plots----
      output$x_distribution <- renderPlot({
        hist_density(
          flowers = r_flowers(),
          col_name = xy_vars()$x_var()
        )
      })

      output$y_distribution <- renderPlot({
        hist_density(
          flowers = r_flowers(),
          col_name = xy_vars()$y_var()
        )
      })
    }
  )
}

Now you only have to go to server.R and provide the new argument to distribution_server():

server <- function(input, output, session) {
  r_flowers <- data_input_server(
    id = "data_input",
    parent_session = session
  )

  xy_vars <- plot_server(
    id = "var_plots",
    r_flowers = r_flowers
  )

  distribution_server(
    id = "dist_plots",
    r_flowers = r_flowers,
    xy_vars = xy_vars
  )
}

Run App and see how we're doing:

image.png

I may not have chosen the best colors in the world but the application does what we want.

Final Touches

Let's first add spinners to the plots in the Distributions tab. Go to distributions_ui() and change the plotOutput()s to this:

# ...
plotOutput(
  outputId = NS(namespace = id, id = "x_distribution")
) |>
  shinycssloaders::withSpinner(
    type = 2,
    color.background = "white"
  )
# ...
# ...
plotOutput(
  outputId = NS(namespace = id, id = "y_distribution")
) |>
  shinycssloaders::withSpinner(
    type = 2,
    color.background = "white"
  )
# ...

Data Input tab UX

It's always easy to use sidebarLayout() when you want the user to upload some data then show a preview. But it has never looked appealing to me especially if the sidebarPanel() only has the fileInput() alone. Appears disproportional to my eye.

image.png

And since recently I've learnt some CSS let's give it a shot and see how different it'll look.

We're going to have fileInput() and the go_to_plot btn on the same fluidRow() then the preview on the fluidRow() below.

Go to data_input_ui() and change it to this:

data_input_ui <- function(id) {
  shiny::tagList(
    fluidRow(
      align = "center",

      column(
        width = 12,

        tags$div(
          class = "upper_row_container",

          tags$div(
            class = "file_input",

            # 1. ----Upload File----
            fileInput(
              inputId = NS(namespace = id, id = "flowers"),
              label = "Upload The Iris Dataset",
              buttonLabel = "+ Select File",
              placeholder = "Drag and Drop File Here (.csv)",
              accept = ".csv",
              width = "90%"
            )
          ),

          tags$div(
            class = "go_to_plot",

            # 3. ----Next Tab Btn----
            shinyjs::hidden(
              actionButton(
                inputId = NS(namespace = id, id = "go_to_plot"),
                label = "Proceed To Plot Tab",
                class = "btn-success",
                style = "font-size: 110%;"
              )
            )
          )
        )
      )
    ),

    tags$br(),
    tags$br(),

    fluidRow(
      column(
        width = 12,
        align = "center",

        # 2. ----Preview----
        tags$div(
          class = "preview",

          DT::DTOutput(
            outputId = NS(namespace = id, id = "preview")
          ) |>
            # Show loading spinner while uploading:
            shinycssloaders::withSpinner(
              type = 2,
              color.background = "white"
            )
        )
      )
    )
  )
}

In the root project directory create the folder /www and inside the new folder create a file named styles.css. You can run these two lines of code on your console to do that:

dir.create("www")
file.create("www/styles.css")

Open styles.css and add this styling:

/* Import some fancy google font */
@import url('https://fonts.googleapis.com/css2?family=Quicksand&display=swap');

/* change all headers to use that font */
h1, h2, h3, h4, h5, h6 {
  font-family: 'Quicksand', sans-serif !important;
}

/* Also change everything in the body to use the fancy font: */
body {
  font-family: 'Quicksand', sans-serif !important;
  font-size: 16px;
}

.upper_row_container {
  /* setting display to grid allows you to align divs in rows and cols
  just like in data.frames: */
  display: grid;

  /* We want to have two columns of equal width 50%-50% just like you'd
  use `fluidRow( column(width = 6), column(width = 6) )` */
  grid-template-columns: repeat(2, 1fr);

  /* Add a gap btwn our columns: */
  gap: 2%;
}

/* style all div children of `upper_row_container`: */
.upper_row_container > div {
  /* setting display to flex allows us finer control of the layout: */
  display: flex;
  align-items: center;
  justify-content: center;
  font-size: 110%;
}

.file_input {
  padding: 10px;
  /* smooth out the corners of the div: */
  border-radius: 5px;

  /* add shadow around the div: */
  box-shadow: 0px 1px 4px 0px rgb(67 76 94);
}

To include the CSS in our application, go to ui.R just after shinyjs::useShinyjs() and add this:

# ...
includeCSS(path = "www/styles.css"), 
#...

Let's also center the columns of the rendered DT::datatable(). Change your datatable_options() to this:

#' Custom `DT::datatable()` options.

#' This function provides some nice defaults for rendering `DT::datatables()`
#' which are also customizable if need arises.
#'
#' @param given_dataframe An object of class data.frame
#' @param scrollY Visible table height
#' @param scrollX Logical: Do you want to enable horizontal scrolling?
#' @param scroller Logical: Should the scroller extension be used?
#' @inheritParams DT::datatable
#' @return An object of class `datatables` and `htmlwidgets`
#' @examples
#' iris |> datatable_options()

datatable_options <- function(
    given_dataframe,
    extensions = "Scroller",
    class = "cell-border",
    scrollY = 400, # Visible table height
    scrollX = TRUE, # Enable horizontal scrolling if table is too wide
    scroller = TRUE # Use the extension "Scroller"
) {
  DT::datatable(
    given_dataframe,
    rownames = FALSE,
    extensions = extensions,
    class = class,
    options = list(
      deferRender = TRUE,
      scrollY = scrollY,
      scrollX = scrollX,
      scroller = scroller,
      columnDefs = list(
        list(
          className = 'dt-center',
          targets = "_all"
        )
      )
    )
  )
}

And finally we always want to have some space between the end of our content and end of screen, so head to ui.R and set the navbarPage() argument called footer as follows:

ui <- navbarPage(
  title = "Shiny Modules",
  id = "tab_container",
  theme = shinytheme(theme = "flatly"),
  # <--- here 👇 ---->
  footer = tags$div(
    tags$br(),
    tags$br()
  ),
  # ...
)

Now when you Run App it should be looking quite decent:

image.png

As usual, find all the code used here.

And actually see the working application here.

Conclusion

As you noticed, working with modules reduces your cognitive load from the whole application down to one specific area of the application. You no longer have to worry about clashing inputIds and all your scripts now look cleaner.

All I'm trynna say is...

image.png

I really hope you picked something out of this series, even if it's not about modules... I mean, those memes weren't so bad.

See you next time.

image.png

 
Share this