speculative evaluation for R shiny

shiny_speculative.R

# I have a shiny app to display points calculated from an image <https://tinypic.host/i/oe0W7x>.
# There is some lag when I pick a new word (by changing number 7 in the picture) that I would like to get rid of.
# I plan to go through these plots in order, so while I'm looking at or clicking on number 7, number 8's plot 
# or points could be calculated. This sort of gets it done: it takes 1s to calculate the points when jumping
# to a plot that isn't in order. But rendering the plot still takes longer than it should. Ideally
# the plot could be prerendered and then the image is just displayed. But that would leave me without input$plot_click
library(pacman)
p_load(tidyverse, ggplot2, jsonlite,
       shiny, keys, magick, promises, future, memoise, tictoc)
plan(multisession)


# Richard Liu produced a json file which identifies the wordsigns in pages of the dictionary.
# I the anniversary edition also presented at https://github.com/richyliu/greggdict
# and https://greggdict.rliu.dev/
json <- jsonlite::read_json("greggdict/assets/Anniversary/reference.json")

# Each row of `d` has a `page` number, a `word` and coordinates
d <- json %>%
        map_dfr(~.x$words %>% map_dfr(as_tibble) %>% mutate(page=.x$page))

# load a page of the dictionary without cropping etc.
gsd_page <- function(page) image_read(paste0("greggdict/assets/Anniversary/pages/", page, ".png"))

# crop, skeletonize and find connected components,
# outputting a data frame with columns x, y, value, t
# where only foreground pixels are included, value is the
# number of the component.
crop_skel_components <- function(png, t, y, x, dy=c(-100,100), dx=c(-100,665), kernel_w=0.5, rescale=50) {
        sz <- image_info(png)
        clamp_x <- function(x) pmax(1, pmin(sz$width, x))
        clamp_y <- function(y) pmax(1, pmin(sz$height, y))
        x1 <- clamp_x(x+dx[1])
        y1 <- clamp_y(y+dy[1])
        w1 <- clamp_x(x+dx[2] - (x1 + dx[1]))
        h1 <- clamp_y(y+dy[2] - (y1 + dy[1])) 
        png %>%
         image_crop(paste0(w1, "x", h1, "+", x1, "+", y1)) %>%
         image_morphology("Thinning", iterations = -1 ) %>%
         image_scale(paste0(rescale, "%")) %>%
         (function(x) {
                xi <- image_info(x)

                # values of the image, low is background/white
                x_bin <- image_data(image_quantize(x, 2), channels='gray')[1,,]

                # connected components numbered
                x_comp <- x %>%
                        image_border("white", "1x1") %>% # background pixels are more connected
                        image_quantize(2) %>%
                        image_connect %>%
                        image_crop(paste0(xi$width,"x",xi$height,"+1+1")) %>% # subtract the border pixels added above
                        image_data(channels='gray') %>%
                         (function(x) x[1,,])
                # each element of us identifies a connected component
                us <- unique(as.numeric(x_comp)[ as.numeric(x_comp) > 0 ])
                map_dfr(us, function(u) {
                         xy <- which(x_comp == u & x_bin < 100, arr.ind=TRUE)
                         tibble(x = xy[,1], y = xy[,2], value = u, t)
                      })
        })
}

# https://stackoverflow.com/questions/70805314/how-to-combine-future-promise-with-memoise-in-r-plumber
cache_fs <- cache_filesystem("/tmp/")
# load, crop, skeletonise, and find connected components of a page
load_page0 <- function(t, y, x, page, dy=c(-100,20), dx=c(-50,500), kernel_w=0.5, rescale=50) {
         crop_skel_components(gsd_page(page), t, y, x, dy, dx, kernel_w, rescale)
}
load_page <- memoise(load_page0, cache = cache_fs)

load_line <- function(i) {
        load_page(d[i,]$t, d[i,]$y, d[i,]$x, d[i,]$page)
}

ui <- fluidPage(
  useKeys(),
  flowLayout(
          numericInput("n", "Selected word", 1, min = 1, max = nrow(d)),
          sliderInput("dx1", "dx1", 0, min = -400, max = 0),
          sliderInput("dx2", "dx2", 800, min = 0, max = 1200),
          sliderInput("dy1", "dy1", -150, min = -400, max = 0),
          sliderInput("dy2", "dy2", 0, min = 0, max = 300),
          sliderInput("w", "w", 0.5, min = 0, max = 3),
          sliderInput("rescale", "rescale", 50, min = 15, max = 100)),
  plotOutput("plot", click = "plot_click", height="600px")
)

server <- function(input, output, session) {
  mk_csc <- function(delta_n=0) { 
        list(t = d[ input$n + delta_n, "t" ],
               y = d[ input$n + delta_n, "y" ],
               x = d[ input$n + delta_n, "x" ],
               page = d[ input$n + delta_n, "page" ],
               dy = c(input$dy1, input$dy2),
               dx = c(input$dx1, input$dx2),
               kernel_w = input$w,
               rescale = input$rescale)
  }
  use_csc <- function(args) do.call(load_page, args)

  call_ggplot <- function(e) {
          ggplot(e, aes(x, -y, col=factor(value))) +
                geom_point(alpha=0.2) +
                coord_fixed() +
                ggtitle(e$t) +
                xlab("") + ylab("")
  }

  output$plot <- renderPlot({
    #print(input$plot_click) # x and y
    csc1 <- mk_csc(1)
    future_promise(use_csc(csc1), packages=c("magick", "tidyverse"),
        globals=c("use_csc", "csc1", "load_page", "load_page0", "gsd_page", "crop_skel_components"))
    tic()
    csc <- mk_csc()
    gg <- use_csc(csc) %>%
            within({ x <- d[input$n, ]$x + x;
                     y <- d[input$n, ]$y + y }) %>%
        call_ggplot
    toc()
    gg
  })

}
shinyApp(ui, server)