Search code examples
rshinydatatablerender

How to clean up the displayed output of a rendered stratification table?


The below example code produces a stratification table of raw data, whereby the user can specify the grouping ranges of the table. See more complete example of flexible stratification table in post How to create a flexible data stratification table?.

I'm trying to format the range outputs in the rendered table to the standard used in my industry ( of [ ### - ### ]. How do I modify the code so the ranges are shown this way? See image at the bottom better explaining what I'm trying to do.

I may need to change the number separator from "-" to <> or equivalence reflecting equality as I show in the below image.

Here's the example code:

library(dplyr)
library(shiny)
library(tidyverse)

ui <-  fluidPage(
  fluidRow(
    column(6,), 
    column(6, uiOutput("time"), 
              numericInput(label = "Stratification ranges:", 'strat_gap','',value=5,step=1,width = '100%')), 
  ),
  fluidRow(
    column(6, h5(strong("Raw data:")),
              tableOutput("data")), 
    column(6, h5(strong("Stratified data:")),
              tableOutput("strat_data"))
  )
)

server <- function(input, output, session) {
  data <- 
      data.frame(
        ID = c(1,1,2,2,2,2,3,3,3),
        Period_1 = c("2020-03", "2020-04", "2020-01", "2020-02", "2020-03", "2020-04", "2020-02", "2020-03", "2020-04"),
        Period_2 = c(1, 2, 1, 2, 3, 4, 1, 2, 3),
        Category = c("Toad", "Toad", "Stool", "Stool", "Stool", "Stool","Toad","Toad","Toad"),
        Values = c(-5, 25, 35, 45, 55, 87, 10, 20, 30)
      )
  
  output$data <- renderTable(data)
  
  output$strat_data <- renderTable({
    breaks <- seq(min(data[,5], na.rm=TRUE), 
                  max(data[,5], na.rm=TRUE), 
                  by=input$strat_gap)
    if(max(breaks) < max(data[,5], na.rm=TRUE)){breaks <- c(breaks, max(breaks) + input$strat_gap)}
    data <- data %>%   
      mutate(sumvar = cut(!!sym("Values"), breaks=breaks, include.lowest=TRUE)) %>% 
      group_by(sumvar) %>%
      summarise(Count = n(), Values = sum(!!sym("Values"))) %>%
      complete(sumvar, fill = list(Count = 0, Values = 0)) %>%
      ungroup %>%
      mutate(Count_pct = sprintf("%.1f%%", (Count/sum(Count))*100), 
             Values_pct = sprintf("%.1f%%", (Values/sum(Values))*100)) %>% 
      dplyr::select(everything(), Count, Count_pct, Values, Values_pct)
    names(data)[1] <- "Ranges"
    data
  })
  
}

shinyApp(ui, server)

enter image description here

Below is the revised output$strat_data... code (server section) reflecting solution proposed by oskjerv (the 2 added rows are flagged):

output$strat_data <- renderTable({
    breaks <- seq(min(data[,5], na.rm=TRUE), 
                  max(data[,5], na.rm=TRUE), 
                  by=input$strat_gap)
    if(max(breaks) < max(data[,5], na.rm=TRUE)){breaks <- c(breaks, max(breaks) + input$strat_gap)}
    
    data <- data %>%   
      mutate(sumvar = cut(!!sym("Values"), breaks=breaks, include.lowest=TRUE)) %>% 
      group_by(sumvar) %>%
        summarise(Count = n(), Values = sum(!!sym("Values"))) %>%
        complete(sumvar, fill = list(Count = 0, Values = 0)) %>%
      ungroup %>%
      mutate(Count_pct = sprintf("%.1f%%", (Count/sum(Count))*100), 
             Values_pct = sprintf("%.1f%%", (Values/sum(Values))*100)) %>% 
      dplyr::select(everything(), Count, Count_pct, Values, Values_pct) %>%
      mutate( sumvar = str_replace(sumvar, "^\\(", "[")) %>% # ADDED
      mutate( sumvar = str_replace(sumvar, "\\,", " to "))   # ADDED
    
    names(data)[1] <- "Ranges"
    data
  })

Solution

  • You should probably play around with str_replace and regular expressions.

    https://regexr.com/ is a great place to start.

    For instance, the code below replaces an opening parentheses at the start of the string with [.

    ^ is an anchor, matching at the start of the string. \\ is to escape the parentheses, since ( has other functions when using regexpr.

    str_replace("(-0,5]", "^\\(", "[")
    

    I am sure there are other answers here on SO that also will be of help.