r Cascadia R会议 - 闪电谈话 - 闪亮的应用程序

Posted 2021-05-24

#libraries
library(shiny)
library(ggplot2)
library(dplyr)
library(DT)
library(tableone)

# data
# mtcars[, c("cyl", "vs", "am", "gear", "carb")] <- lapply(mtcars[, c("cyl", "vs", "am", "gear", "carb")], factor)
# data1
# TODO: Enter factor_vars
factor_vars <- c("cyl", "vs", "am", "gear", "carb")
mtcars[, factor_vars] <- lapply(mtcars[, factor_vars], factor)

# histogram function
ggMeanMedian <- function(x, data, binwidth){
  
  require(ggplot2)
  ggplot(data = data, aes(x = x)) + 
    geom_histogram(aes(y = ..density..), binwidth = binwidth, 
                   colour = "black", fill = "white") + 
    geom_density(alpha = .2, fill = "#FF6666") +
    geom_vline(aes(xintercept = mean(x), color = "mean"),
               linetype = "dashed", size = 2) +
    geom_vline(aes(xintercept = median(x), color = "median"),
               linetype = "dashed", size = 2) +
    scale_color_manual(name = "Dispersion",
                       values = c(median = "blue", mean = "red"))
}

# user interface
ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      selectInput("var", label = "Select a variable to see a summary plot:",
                  choices = names(mtcars), multiple = FALSE), 
      radioButtons("strata", label = "Stratify by another variable?", 
                   choices = c("No", "Yes"), selected = "No"), 
      conditionalPanel("input.strata == 'Yes'",
        selectInput("y", label = "Stratify by:", 
                    choices = factor_vars, multiple = FALSE)
      )
    ),
    mainPanel(tabsetPanel(
                tabPanel("Table", DT::dataTableOutput("table"), 
                                  plotOutput("plot")), 
                tabPanel("Introduction", verbatimTextOutput("text1")), 
                tabPanel("Talking Points", verbatimTextOutput("text2"))
                         ))
  )
)

# server
server <- function(input, output, session){
  
  observe({
    input$var
    vars <- input$var
    updateSelectInput(session = session, inputId = "y",
                      choices = factor_vars[factor_vars != vars])
  })
  
  output$table <- DT::renderDataTable({
    if(input$strata == "No"){
      tbl <- CreateTableOne(vars = input$var, data = mtcars)
      tbl1 <- print(tbl, showAllLevels = TRUE, test = FALSE)
      colnames(tbl1) <- c("levels", "Overall (%)")
      datatable(tbl1, caption = paste("Descriptive Statistics of", input$var),
                selection = list(mode = "single", target = "row"),
                class = 'cell-border strip hover', options = list(dom = 't'))
    } else {
      tbl <- CreateTableOne(vars = input$var, strata = input$y, data = mtcars)
      tbl1 <- print(tbl, showAllLevels = TRUE, test = FALSE)
      datatable(tbl1, caption = paste("Descriptive Statistics of", input$var, "stratified by", input$y),
                selection = list(mode = "single", target = "row"),
                class = 'cell-border strip hover', options = list(dom = 't'))
    }
    
  })
  
  output$plot <- renderPlot({
    
    if(input$strata == "No"){
      p <- ggplot(data = mtcars)
      info = input$table_rows_selected
      
      if(is.null(info) || is.na(info)){
        return()
      } else if(info == 1){
        text = paste("A row containing sample size information.")
        ggplot() + annotate("text", x = 4, y = 25, size=8, label = text) + 
        theme_bw() + theme(panel.grid.major=element_blank(), panel.grid.minor=element_blank())
      } else if(info >= 2 & is.factor(mtcars[[input$var]]) == FALSE){
        p <- ggMeanMedian(x = mtcars[[input$var]], data = mtcars, binwidth = 3)
        p <- p + xlab(paste(input$var))
        print(p)
      } else if(info >= 2 & is.factor(mtcars[[input$var]]) == TRUE){
        info = info - 1
        mtcars$highlight <- ifelse(mtcars[[input$var]] == levels(mtcars[[input$var]])[info], "highlight", "not")
        p <- ggplot(data = mtcars)
        p <- p + geom_bar(aes(x = mtcars[[input$var]], fill = highlight), width = 0.5) +
          xlab(paste(input$var)) + 
          theme(legend.position = 'none')
        print(p)
      }
    } else {
      p <- ggplot(data = mtcars)
      info = input$table_rows_selected
      
      if(is.null(info) || is.na(info)){
        return()
      } else if(info == 1){
        text = paste("A row containing sample size information.")
        ggplot() + annotate("text", x = 4, y = 25, size=8, label = text) + 
          theme_bw() + theme(panel.grid.major=element_blank(), panel.grid.minor=element_blank())
      } else if(info >= 2 & is.factor(mtcars[[input$var]]) == FALSE){
        p <- ggMeanMedian(x = mtcars[[input$var]], data = mtcars, binwidth = 3)
        facets <- paste('.', '~', input$y)
        p <- p + facet_grid(facets) +
          xlab(paste(input$var))
        print(p)
      } else if(info >= 2 & is.factor(mtcars[[input$var]]) == TRUE){
        info = info - 1
        mtcars$highlight <- ifelse(mtcars[[input$var]] == levels(mtcars[[input$var]])[info], "highlight", "not")
        p <- ggplot(data = mtcars)
        p <- p + geom_bar(aes(x = mtcars[[input$var]], fill = highlight), width = 0.5) +
          facet_grid(mtcars[[input$var]] ~ mtcars[[input$y]]) +
          xlab(paste(input$var)) + 
          theme(legend.position = 'none')
        print(p)
      }
    }
     
  })
  
  output$text1 <- renderText({
    paste("Title: Amending Descriptive Statistics Tables w/ Dynamic Visualizations", 
          "\n",
           "or what it should have been called:\n How to make your tables NOT SUCK", 
           "\n", 
           "Packages used: DT & tableone", 
          "\n", 
          "(Please note that I know I am preaching to the choir)",
          sep = "\n")
  })
  
  output$text2 <- renderText({
    paste("- Delivering Tables or Plots to Collaborators", 
          "\n", 
          "- Easily Digestible", 
          "\n", 
          "- Slowly talk through important variables", 
          "\n", 
          "- Do you really need a table that spans over a page?",
          sep = "\n")
  })

}

shinyApp(ui = ui, server = server)