R/ggplot2Addin.R

In homerhanumat/addinggplot2: RStudio Addin for Interactive Plotting with ggplot2

#' Make a plot with \code{ggplot2}.
#'
#' Interactively make a \code{ggplot2} plot. The resulting
#' code will be emitted to the source file or console.
#'
#' Here's how you use it:
#'
#' 1. Highlight a symbol naming a \code{data.frame} in your R session,
#'    e.g. \code{mtcars},
#' 2. Execute this addin and interactively build the plot.
#'
#' When you're happy with the plot, press Done.  The code for
#' the plot  will be be placed at the cursor position.
#'
#' @export
ggplot2Addin <- function() {
  
  # Get the document context.
  context <- rstudioapi::getActiveDocumentContext()
  
  # Set the default data to use based on the selection.
  text <- context$selection[[1]]$text
  defaultData <- text
  
  # UI for gadget ---------------------------------
  ui <- miniPage(
    useShinyCustom(),
    gadgetTitleBar("ggplot2 Code-Helper"),
    miniContentPanel(
      sidebarLayout(
        sidebarPanel(width = 2,
                     textInput("data", "Data", value = defaultData),
                     uiOutput("xVar"),
                     uiOutput("yVar")
                     
        ),
        mainPanel(width = 10,
                  tabsetPanel(id = "buildertabs",
                              tabPanel(
                                title = "First Layer",
                                uiOutput("pending1"),
                                fluidRow(
                                  column(width = 5,
                                         h3("The Plot"),
                                         plotOutput("plot1")),
                                  column(width = 5,
                                         h3("The Code"),
                                         br(),
                                         verbatimTextOutput("code1"))
                                )
                                ,
                                fluidRow(
                                  column(width = 4, uiOutput("geom"))
                                )
                              ), #end tabPanel "First Layer"
                              tabPanel(
                                title = "Facet",
                                uiOutput("pending2"),
                                fluidRow(
                                  column(width = 5,
                                         h3("The Plot"),
                                         plotOutput("plot2")),
                                  column(width = 5,
                                         h3("The Code"),
                                         br(),
                                         verbatimTextOutput("code2"))
                                )
                              )  # end tabPanel "Facet"
                  ) # end tabsetPanel
        ) # end MainPanel
      ) # end sidebarLayout
    ) # end miniContentPanel
  ) # end miniPage
  
  
  # Server code for the gadget.
  server <- function(input, output, session) {
    
    ## Reactive Values ----------------
    ###########################
    
    rv <- reactiveValues(
      code = NULL
    )
    
    ## Reactive functions -------------------
    ################################
    
    # fetch the data frame
    reactiveData <- reactive({
      dataString <- input$data
      if (!nzchar(dataString)) {
        return(errorMessage("data", "No dataset available."))
      }
      
      if (!exists(dataString, envir = .GlobalEnv)) {
        return(errorMessage("data", paste("No dataset named '",
                                          dataString, "' available.")))
      }
      
      data <- get(dataString, envir = .GlobalEnv)
      data
    })
    
    # check to see if primary variables have been entered
    reactiveVarCheck <- reactive({
      entered(input$xVar)
    })
    
    # check to see if primary variables have been entered
    reactiveVarCheck <- reactive({
      entered(input$xVar)
    })
    
    # our code-maker
    observe({
      xvar <- input$xVar
      if ( !reactiveVarCheck() ) {
        return("No code to show yet!")
      }
      
      code <- paste0("ggplot(data = ",input$data,",\n\tmapping = aes(x = ")
      
      if (entered(input$xVar)) {
        code <- paste0(code,input$xVar)
      }
      
      if (entered(input$yVar)) {
        code <- paste0(code, ", y= ",input$yVar)
      }
      
      code <- paste0(code,"))")
      
      if (entered(input$geom)) {
        code <- paste0(code, " +\n\tgeom_",input$geom,"(na.rm = TRUE)")
      }
      
      rv$code <- code
    })
    
    # hair-trigger plotting (code not isolated)
    makeplot <- reactive({
      data <- reactiveData()
      if (isErrorMessage(data))
        return(NULL)
      
      if (!reactiveVarCheck()) {
        return(NULL)
      } else {
        command <- rv$code
        eval(parse(text = command))
      }
    })
    
    
    ## Primary Variables --------------------
    ############################
    
    output$xVar <- renderUI({
      data <- reactiveData()
      selectInput(inputId = "xVar", label = "Aesthetic: x-axis",
                  choices = c("", find_facnum_vars(data)),
                  selected = "")
    })
    
    output$yVar <- renderUI({
      data <- reactiveData()
      selectInput(inputId = "yVar", label = "Aesthetic: y-axis",
                  choices = c("", find_facnum_vars(data)),
                  selected = "")
    })
    
    
    ## For groups tab -------------------------
    #############################
    
    output$pending1 <- renderUI({
      data <- reactiveData()
      if (isErrorMessage(data))
        h4(style = "color: #AA7732;", data$message)
    })
    
    output$plot1 <- renderPlot({
      makeplot()
    })
    
    output$code1 <- renderText({
      rv$code
    })
    
    output$geom <- renderUI({
      if (!reactiveVarCheck()) {
        return(NULL)
      }
      selectInput(inputId = "geom", label = "Geom:",
                  choices = c("", c("bar","histogram","point")),
                  selected = "")
    })
    
    
    ## Finish Up ----------------------
    #######################
    
    # Listen for Done.
    observeEvent(input$done, {
      
      # Get code to user:
      if (reactiveVarCheck()) {
        code <- rv$code
        rstudioapi::insertText(text = code)
      } else {
        return(NULL)
      }
      
      invisible(stopApp())
    })
  }
  
  # Use a browser as a viewer.
  viewer <- browserViewer()
  runGadget(ui, server, viewer = viewer)
  
}