A function which launches a Shiny app for hand coding (manually classifying) data.

classify.R

#' Manual classification of observations
#' 
#' \code{classify} launches a Shiny app to manually classify a subset of observations.
#'
#' @param x A character vector.
#' @param btn_labels A character vector of length 2 corresponding to 0 and 1.
#' @return A vector of 0/1 for each element in \code{x}.
#' @export
#' @examples \dontrun{
#'  foo <- sprintf('%s (%.2f miles per gallon)', rownames(mtcars), mtcars$mpg)
#'  y <- classify(foo,c("Bad mileage for this car", "Good mileage for this car"))
#' }

classify <- function(x, btn_labels = c('No', 'Yes')) {
  if ( "shiny" %in% rownames(installed.packages()) ) {
    n <- length(x)
    e <- new.env() # where we store classifications
    e$classifications <- rep(NA, n) # 0 = no, 1 = yes
    e$no <- 0
    e$yes <- 0
    shiny::runApp(shiny::shinyApp(
      ui = shiny::fluidPage(
        # Uses left arrow key for "no" and right arrow key for "yes"
        shiny::tags$head(shiny::tags$script('$(document).on("keyup", function (e) {
          if ( e.which == 37 ) document.getElementById("no").click();
          if ( e.which == 39 ) document.getElementById("yes").click();
        });')),
        shiny::br(), shiny::uiOutput("progress"),
        shiny::plotOutput("progressBar", height = "10px"), shiny::br(),
        shiny::uiOutput("text"), shiny::br(),
        shiny::actionButton("no", btn_labels[1]),
        shiny::actionButton("yes", btn_labels[2]),
        shiny::helpText(sprintf('Use left and right arrow keys to mark it as "%s" or "%s", respectively.',
                                btn_labels[1], btn_labels[2]))
        ),
      server = function(input, output) {
        output$progress <- shiny::renderUI({
          i <- input$no + input$yes
          HTML(sprintf("<strong>Observation %.0f of %.0f (%.2f%% done)</strong>", i+1, n, 100*i/n))
        })
        output$progressBar <- shiny::renderPlot({
          i <- (input$no + input$yes)/n
          par(mar = rep(0, 4) + 0.01, oma = rep(0, 4), bg = "grey90")
          plot(0, 0, type = "n", xlim = c(0, 1), ylim = c(0, 1), xaxs = "i", yaxs = "i")
          polygon(c(0, i, i, 0), c(0, 0, 1, 1), col = "cornflowerblue", border = NA)
        })
        output$text <- shiny::renderUI({
          a <- input$no
          b <- input$yes
          i <- a + b + 1
          if ( a>e$no ) {
            eval(parse(text = sprintf("classifications[%.0f] <- 0",i-1)), envir = e)
            eval(parse(text = sprintf("no <- %0.f",a)), envir = e)
          }
          if ( b>e$yes ) {
            eval(parse(text = sprintf("classifications[%.0f] <- 1",i-1)), envir = e)
            eval(parse(text = sprintf("yes <- %0.f",b)),envir=e)
          }
          if ( i>0 & i<=n ) sprintf("%s", x[i])
          else { shiny::stopApp("Done!") }
        })
      }
      ), launch.browser = ifelse(Sys.getenv("RSTUDIO") == "1", rstudio::viewer, TRUE)
    )
    return(e$classifications)
  } else {
    stop("Requires 'shiny' package to be installed.")
  }
}