R/selectR.R

In riccardopinosio/selectR:

#' S3 class constructor for selector objects
#'
#' This function constructs a selector object
#'
#' @return An object of type selector
new_selector <- function(data_frame,
                         text,
                         selections = NULL,
                         selections_type = NULL,
                         selections_format = NULL,
                         id = NULL,
                         library = 'select2',
                         folder = NULL){
  selector_obj <- structure(
    list(
      data = data_frame,
      text = text,
      selections = selections,
      selections_type = selections_type,
      selections_format = selections_format,
      id = id,
      library = library,
      folder = folder
    ),
    class = c(library, 'selector')
  )
  selector_obj
}

#' Create a select box
#'
#' This is the main function of the package. It can
#' be used to create select boxes and pass various
#' options, among which the library to be used to
#' render the select box (currently only select2 is
#' supported).
#'
#' @param data_frame A data frame, or an object coercible to one
#' @param text The bare name of the column containing the text for the selector
#' @param selections The bare name of the column containing the data for the possible selections
#' @param selection_format If the selections are plots or functions returning
#' plots, the format to be used for the plots. See details.
#' @param id The bare name of the column containing the ids for the selector
#' @param library The library used to render the select box; see details
#' @param folder The folder used to save to disk intermediate files; see details.
#' @param ... Other parameters to be passed to the selector library
#'
#'@section Details:
#'The selections parameter must be the bare (unquoted) name of the column
#'in the dataframe that contains the selections (plots or widgets) to be
#'associated to the selector.
#'If the selection column contains functions, it is assumed that these functions
#'return plots that can be converted to either png or svg.
#'If the selection column contains plots, one can specify whether they are to
#'be rendered as png (default) or as svg (using the svglite package).
#'
#' @return An object of class selector
#' @export
#'
#' @examples
selectR <- function(data_frame,
                    text,
                    selections = NULL,
                    selections_format = 'png',
                    id = NULL,
                    library = 'select2',
                    folder = NULL,
                    ...) {
  #need to do some validation here

  #capture textcol
  text_col <- quo_text(enquo(text))
  text_vec <- data_frame[[text_col]]
  text_vec <- as.character(text_vec)

  #if the id col is not specified, try to guess.
  #if guess fails, take row number
  if (is.null(id)){
    id_cols <- grep("^id$|^ID$|_id$", names(data_frame), value = TRUE)
    if (length(id_cols) == 0){
      #take the row number
      id_vec <- seq(1, length(text_vec))
    } else {
      #take the first occurrence
      id_vec <- data_frame[[id_cols[[1]]]]
    }
  }

  #capture selections col if passed
  selections_col <- quo_text(enquo(selections))
  if (selections_col != 'NULL'){
    selections_vec <- data_frame[[selections_col]]
  } else {
    selections_col <- NULL
  }

  #construct new selector object
  selector <- new_selector(
    data_frame = data_frame,
    text = text_vec,
    selections = selections_vec,
    selections_type = NULL,
    selections_format = selections_format,
    id = id_vec,
    library = library,
    folder = folder
  )

  #figure out selection type
  if (is.null(selector$selections_type)){
    selector <- determine_selections_type(selector)
  }

  #perform conversions
    selector <- convert_selections(selector)

  selector
}

#' Converts plots to base64 strings
#'
#' @param img The plot to be converted
#' @param dir The directory where to save the plots if needed
#'
#' @return a string with the base64 encoding of the plot
encode_image <- function(img, selections_format, dir = NULL){
  temp <- tempfile()

  if (!is.null(dir)){
    temp <- paste(sample(c(1:9, letters), 20, replace = TRUE), collapse = '')
    temp <- file.path(dir, temp)
  }

  if (selections_format == 'png'){
    temp <- paste0(temp, '.png')
    Cairo::Cairo(filename = tempfile, dpi = 150, width = 960, height = 500, #must be made relative!
                 units = 'px')

    if (inherits(img, 'function')){
      img()
    } else {
      print(img)
    }

    i  = Cairo:::.image(dev.cur())
    r = Cairo:::.ptr.to.raw(i$ref, 0, i$width * i$height * 4)
    dim(r) = c(4, i$width, i$height)
    r[c(1,3),,] = r[c(3,1),,]
    pl <- png::writePNG(r, raw())
    dev.off()
    pl <- paste0("data:image/png;base64,", base64enc::base64encode(pl))
    return(pl)
  } else if (selections_format == 'svg'){
    st <- svglite::svgstring()

    if (inherits(img, 'function')){
      img()
    } else {
      print(img)
    }
    st <- st()
    dev.off()
    st <- as.character(st)
    st <- gsub("[\r\n]", "", st)
    st
  }
}


#' Convert selection column
#'
#' Check if the selection column of the selector needs conversion.
#' If it does, execute the conversion and return a new selector
#' object.
#'
#' @param selector A selector object
#'
#' @return A selector object
convert_selections <- function(selector){
  selections <- selector$selections
  selections_type <- selector$selections_type
  selections_format <- selector$selections_format

  if (selections_type == 'img'){
    encodings <- purrr::map(selections, function(sel){
      encode_image(sel, selections_format)
    })

    selector$selections <- encodings
  }

  selector
}

#should be vectorised for speed
base_to_img <- function(base){
  htmltools::tags$img(src = base)
}


#' Print method for selectors
#'
#'Custom method for printing selectors;
#'converts them to htmlwidgets.
#'
#' @param x
#' @param ...
#'
#' @return
#' @export
print.selector <- function(x, ...){
  print(as_widget(x))
}


#' Convert an selector object to htmlwidgets
#'
#' Given a selector object, this function converts
#' it to an htmlwidget.
#'
#' @param selector The selector object
#' @param width The width parameter passed on to htmlwidgets
#' @param height The height parameter passed on to htmlwidgets
#'
#' @return An oject of class htmlwidgets
#' @export
as_widget <- function(selector,
                      width = NULL,
                      height = NULL){

  selector_data <- list(
    text = selector$text,
    id = selector$id,
    selections = selector$selections,
    selections_type = selector$selections_type,
    library = class(selector)[[1]]
  )

  htmlwidgets::createWidget(
    name = 'selectR',
    x = selector_data,
    width = width,
    height = height,
    package = 'selectR'
  )
}

#attempt to determine the type of the selections column
determine_selections_type <- function(selector){
  selections <- selector$selections
  is_img <- all(purrr::map_lgl(selections, function(s){
    inherits_any(s, c('ggplot', 'function'))
  }))

  if (is_img){
    selections_type <- "img"
  }

  selector$selections_type <- selections_type
  selector
}
















##SHINY STUFF LATER!

#' Shiny bindings for selectR
#'
#' Output and render functions for using selectR within Shiny
#' applications and interactive Rmd documents.
#'
#' @param outputId output variable to read from
#' @param width,height Must be a valid CSS unit (like \code{'100\%'},
#'   \code{'400px'}, \code{'auto'}) or a number, which will be coerced to a
#'   string and have \code{'px'} appended.
#' @param expr An expression that generates a selectR
#' @param env The environment in which to evaluate \code{expr}.
#' @param quoted Is \code{expr} a quoted expression (with \code{quote()})? This
#'   is useful if you want to save an expression in a variable.
#'
#' @name selectR-shiny
#'
#' @export
selectROutput <- function(outputId, width = '100%', height = '400px'){
  htmlwidgets::shinyWidgetOutput(outputId, 'selectR', width, height, package = 'selectR')
}

#' @rdname selectR-shiny
#' @export
renderSelectR <- function(expr, env = parent.frame(), quoted = FALSE) {
  if (!quoted) { expr <- substitute(expr) } # force quoted
  htmlwidgets::shinyRenderWidget(expr, selectROutput, env, quoted = TRUE)
}


#handy development functions

create_example <- function(){
  dat <- ggplot2::diamonds %>%
    select(carat, depth, table, price, x, y, z)
  plots <- purrr::map2('carat', names(dat), function(a,b){
    ggplot(dat, aes_string(x = a, y = b)) + geom_smooth()
  })

  #base plot
  p <- function(){plot(1:10)}
  plots[[8]] <- p

  frame <- tibble(vars = c(paste0('carat', ' vs ', names(dat)), 'base'),
                  plots = plots)
  frame
}

dev_libs <- function(){
  library(ggplot2)
  library(dplyr)
}