# RafikiArdhi: connect the Excel add-in's R tab to your own R
# ----------------------------------------------------------------------------------------------
# Run this in R or RStudio:
#
#   source("https://rafikiardhi.earth/excel/rafikiardhi-connect.R")
#   connect()
#
# It prints a one-time code. In Excel, open the add-in's R tab, choose "My R" and paste the code.
# The R tab then runs its code in THIS R session: your packages, your functions, your objects.
# Anything the R tab creates (df, results) is in your workspace too, and the other way round.
#
# Safety: the link only listens on this computer (127.0.0.1), only answers the add-in's own web
# address, and needs the one-time code, so no other website or computer can send it code.
# disconnect() (or closing R) ends it. Needs the packages httpuv and jsonlite (installed if missing).
# ----------------------------------------------------------------------------------------------

local({
  for (p in c("httpuv", "jsonlite")) if (!requireNamespace(p, quietly = TRUE)) utils::install.packages(p)
})

.rafikiardhi <- new.env()
.rafikiardhi$origins <- c("https://rafikiardhi.earth", "https://www.rafikiardhi.earth")
.rafikiardhi$version <- "1.2"

# what to_excel() makes of an object: sheets (a name and a data frame) and pictures (a name and a plot)
.ra_is_plot <- function(x) inherits(x, c("ggplot", "gg", "recordedplot", "trellis", "grob", "gtable", "patchwork"))
.ra_draw <- function(x) {
  if (inherits(x, "recordedplot")) grDevices::replayPlot(x)
  else if (inherits(x, c("grob", "gtable")) && !inherits(x, "ggplot")) { grid::grid.newpage(); grid::grid.draw(x) }
  else print(x)
  invisible()
}
.ra_parts <- function(x, name, depth = 0) {
  nm <- substr(trimws(gsub("[^A-Za-z0-9 _.-]", " ", name)), 1, 28)
  if (!nzchar(nm)) nm <- "R result"
  tab <- function(y) {
    y <- as.data.frame(y, stringsAsFactors = FALSE)
    rn <- rownames(y)
    if (!is.null(rn) && !identical(rn, as.character(seq_len(nrow(y))))) y <- cbind(row = rn, y, stringsAsFactors = FALSE)
    list(list(name = nm, df = y))
  }
  one <- function(v) if (is.null(v)) NA else if (length(v) > 1) paste(signif(unlist(v), 6), collapse = ", ") else unname(v)
  if (is.null(x)) return(list())
  if (.ra_is_plot(x)) return(list(list(name = nm, plot = x)))
  if (is.data.frame(x)) return(tab(x))
  if (is.table(x)) return(tab(if (length(dim(x)) == 2) as.data.frame.matrix(x) else as.data.frame(x)))
  if (is.matrix(x)) return(tab(x))
  if (inherits(x, "htest"))
    return(tab(data.frame(test = one(x$method), data = one(x$data.name), statistic = one(x$statistic), parameter = one(x$parameter),
      p.value = one(x$p.value), estimate = one(x$estimate), conf.int = one(x$conf.int), alternative = one(x$alternative))))
  if (inherits(x, "summary.aov")) return(tab(x[[1]]))
  if (inherits(x, "aov")) return(tab(summary(x)[[1]]))
  if (is.object(x) && !is.atomic(x)) {   # models: lm, glm, nls, mixed models … the coefficient table, plus the fit for lm and glm
    s <- if (grepl("^summary", class(x)[1])) x else tryCatch(summary(x), error = function(e) NULL)
    cm <- tryCatch(stats::coef(s), error = function(e) NULL)
    if (is.matrix(cm) || is.data.frame(cm)) {
      out <- tab(cm)
      fit <- c(r.squared = one(s$r.squared), adj.r.squared = one(s$adj.r.squared), sigma = one(s$sigma),
        AIC = tryCatch(stats::AIC(x), error = function(e) NA), n = tryCatch(stats::nobs(x), error = function(e) NA))
      fit <- unlist(fit)
      fit <- fit[!is.na(fit)]
      if (length(fit)) out <- c(out, list(list(name = substr(paste(nm, "stats"), 1, 28), df = data.frame(statistic = names(fit), value = unname(fit)))))
      return(out)
    }
  }
  if (is.factor(x)) x <- as.character(x)
  if (is.atomic(x)) {
    if (!is.null(names(x))) return(tab(data.frame(name = names(x), value = unname(x), stringsAsFactors = FALSE, row.names = NULL)))
    y <- data.frame(x, stringsAsFactors = FALSE); names(y) <- nm; return(tab(y))
  }
  if (is.list(x) && !is.function(x)) {
    if (length(x) && all(vapply(x, function(v) is.atomic(v) && length(v) == 1, logical(1)))) {
      k <- names(x); if (is.null(k)) k <- seq_along(x)
      return(tab(data.frame(name = k, value = vapply(x, function(v) as.character(v), ""), stringsAsFactors = FALSE, row.names = NULL)))
    }
    if (depth < 2 && length(x) <= 25) {   # each part on its own sheet (or picture)
      k <- names(x); if (is.null(k)) k <- seq_along(x); k[!nzchar(k)] <- seq_along(x)[!nzchar(k)]
      return(do.call(c, lapply(seq_along(x), function(i) .ra_parts(x[[i]], paste(name, k[i]), depth + 1))))
    }
  }
  tab(data.frame(output = utils::capture.output(print(x)), stringsAsFactors = FALSE))   # anything else: as R prints it
}
# the variables pane: one line per object, "name<TAB>kind<TAB>description"
.ra_vars <- function(env = globalenv()) {
  out <- character()
  for (k in ls(env)) {
    x <- get(k, envir = env)
    if (is.function(x)) next
    kind <- if (.ra_is_plot(x)) "plot" else if (is.data.frame(x)) "table" else "other"
    d <- tryCatch({
      if (.ra_is_plot(x)) paste("plot,", if (inherits(x, "ggplot")) "ggplot" else class(x)[1])
      else if (is.data.frame(x)) sprintf("%d obs. of %d variables", nrow(x), ncol(x))
      else if (is.matrix(x)) sprintf("matrix, %d x %d", nrow(x), ncol(x))
      else if (inherits(x, "htest")) x$method
      else if (is.object(x) && !is.atomic(x)) paste(class(x), collapse = ", ")
      else if (is.list(x)) sprintf("list of %d", length(x))
      else utils::capture.output(utils::str(x, give.attr = FALSE, vec.len = 2, width = 70, strict.width = "cut"))[1]
    }, error = function(e) class(x)[1])
    out <- c(out, paste(k, kind, gsub("[[:space:]]+", " ", trimws(d)), sep = "\t"))
  }
  out
}

# to_excel(x, name): send almost anything to Excel: tables to new sheets, plots as pictures (also works in the built-in R)
to_excel <- function(x, name = deparse(substitute(x))) {
  name <- paste(name, collapse = " ")
  parts <- .ra_parts(x, name)
  if (!length(parts)) { message("Nothing to send."); return(invisible(x)) }
  q <- get0("queue", envir = .rafikiardhi, ifnotfound = list())
  for (p in parts) {
    if (!is.null(p$plot)) {   # drawn on its own at twice the screen size, so it is sharp in the sheet
      f <- tempfile(fileext = ".png"); cur <- grDevices::dev.cur()
      grDevices::png(f, width = 1440, height = 1040, res = 144)
      tryCatch(.ra_draw(p$plot), finally = grDevices::dev.off())
      if (cur > 1 && cur %in% grDevices::dev.list()) grDevices::dev.set(cur)
      q[[length(q) + 1]] <- list(name = p$name, img = jsonlite::base64_enc(readBin(f, "raw", file.info(f)$size))); unlink(f)
    } else {
      con <- textConnection("csv_out", "w", local = TRUE)
      utils::write.csv(p$df, con, row.names = FALSE, na = "")
      close(con)
      q[[length(q) + 1]] <- list(name = p$name, csv = paste(csv_out, collapse = "\n"))
    }
  }
  assign("queue", q, envir = .rafikiardhi)
  message("Sent to Excel: ", name, if (length(parts) > 1) paste0(" (", length(parts), " sheets or pictures)"))
  invisible(x)
}

# run code the way the console does: each expression echoed, printed if visible, stop at the first error
.rafikiardhi_run <- function(code) {
  out <- list(); add <- function(type, text) if (length(text) && any(nzchar(text))) out[[length(out) + 1]] <<- list(type = type, text = paste(text, collapse = "\n"))
  exprs <- tryCatch(parse(text = code, keep.source = TRUE), error = function(e) e)
  if (inherits(exprs, "error")) { add("err", paste("Error:", sub("^<text>:", "", conditionMessage(exprs)))); return(list(output = out, plots = list(), tables = list())) }
  src <- attr(exprs, "srcref")
  old_dev <- grDevices::dev.cur()
  pngs <- file.path(tempdir(), paste0("ra_plot_", as.integer(Sys.time()), "_%03d.png"))
  grDevices::png(pngs, width = 720, height = 520)
  ra_dev <- grDevices::dev.cur()
  grDevices::dev.control("enable")   # keep a recording of each plot, so the plot window can redraw it at any size
  pages <- function() length(Sys.glob(sub("%03d", "*", pngs, fixed = TRUE)))
  recs <- list()
  on.exit({ if (ra_dev %in% grDevices::dev.list()) grDevices::dev.off(ra_dev); if (old_dev > 1 && old_dev %in% grDevices::dev.list()) grDevices::dev.set(old_dev) }, add = TRUE)
  for (i in seq_along(exprs)) {
    add("in", paste0(c("> ", rep("+ ", 1000))[seq_along(s <- as.character(src[[i]]))], s))
    failed <- FALSE
    printed <- utils::capture.output(
      withCallingHandlers(
        tryCatch({
          r <- withVisible(eval(exprs[[i]], envir = globalenv()))
          if (r$visible) print(r$value)
        }, error = function(e) { failed <<- TRUE; cl <- conditionCall(e); where <- if (is.null(cl)) "" else deparse(cl)[1]
          add("err", paste0("Error", if (nzchar(where) && !startsWith(where, "eval(exprs")) paste0(" in ", where), ": ", conditionMessage(e))) }),
        message = function(m) { add("msg", sub("\n$", "", conditionMessage(m))); invokeRestart("muffleMessage") },
        warning = function(w) { add("msg", paste("Warning:", conditionMessage(w))); invokeRestart("muffleWarning") }),
      type = "output")
    add("out", printed)
    pg <- pages()
    if (pg > 0 && ra_dev %in% grDevices::dev.list()) {
      cur <- grDevices::dev.cur(); grDevices::dev.set(ra_dev)
      r <- tryCatch(grDevices::recordPlot(), error = function(e) NULL)
      if (!is.null(r)) recs[[pg]] <- r
      if (cur != ra_dev && cur %in% grDevices::dev.list()) grDevices::dev.set(cur)
    }
    if (failed) break
  }
  grDevices::dev.off(ra_dev)
  files <- sort(Sys.glob(sub("%03d", "*", pngs, fixed = TRUE)))
  plots <- lapply(seq_along(files), function(i) {
    f <- files[i]; b <- jsonlite::base64_enc(readBin(f, "raw", file.info(f)$size)); unlink(f)
    id <- .rafikiardhi$next_id <- (get0("next_id", envir = .rafikiardhi, ifnotfound = 0) + 1)
    if (i <= length(recs) && !is.null(recs[[i]])) {
      kept <- get0("plots", envir = .rafikiardhi, ifnotfound = list()); kept[[as.character(id)]] <- recs[[i]]
      if (length(kept) > 50) kept <- kept[-1]   # the last 50 plots can be redrawn
      assign("plots", kept, envir = .rafikiardhi)
    }
    list(id = id, img = b)
  })
  tables <- get0("queue", envir = .rafikiardhi, ifnotfound = list()); assign("queue", list(), envir = .rafikiardhi)
  list(output = out, plots = plots, tables = tables)
}

connect <- function(port = 8765) {
  disconnect(quiet = TRUE)
  # a fresh random code that doesn't depend on (or change) the user's own set.seed()
  had <- exists(".Random.seed", envir = globalenv()); if (had) old <- get(".Random.seed", envir = globalenv())
  set.seed(as.integer((as.numeric(Sys.time()) * 1e3 + Sys.getpid() * 7919) %% .Machine$integer.max))
  token <- paste(sample(c(LETTERS[-c(9, 15)], 2:9), 8, replace = TRUE), collapse = "")
  if (had) assign(".Random.seed", old, envir = globalenv()) else rm(".Random.seed", envir = globalenv())
  .rafikiardhi$token <- token
  headers <- function(origin) list(
    "Access-Control-Allow-Origin" = origin, "Access-Control-Allow-Methods" = "POST, OPTIONS",
    "Access-Control-Allow-Headers" = "Content-Type", "Access-Control-Allow-Private-Network" = "true",
    "Vary" = "Origin", "Content-Type" = "application/json")
  reply <- function(status, body, origin) list(status = status, headers = headers(origin), body = jsonlite::toJSON(body, auto_unbox = TRUE, null = "null"))
  app <- list(call = function(req) {
    origin <- req$HTTP_ORIGIN %||% ""
    if (!origin %in% .rafikiardhi$origins) return(list(status = 403L, headers = list("Content-Type" = "text/plain"), body = "Not allowed."))
    if (req$REQUEST_METHOD == "OPTIONS") return(list(status = 204L, headers = headers(origin), body = ""))
    if (req$REQUEST_METHOD != "POST") return(reply(405L, list(ok = FALSE), origin))
    b <- tryCatch(jsonlite::fromJSON(rawToChar(req$rook.input$read()), simplifyVector = FALSE), error = function(e) list())
    if (!identical(toupper(gsub("[^A-Za-z0-9]", "", b$token %||% "")), .rafikiardhi$token)) return(reply(401L, list(ok = FALSE, error = "Wrong code. Run connect() again in R and paste the new code."), origin))
    path <- req$PATH_INFO
    if (path == "/ping") return(reply(200L, list(ok = TRUE, r = R.version.string, version = .rafikiardhi$version), origin))
    if (path == "/vars") return(reply(200L, list(ok = TRUE, vars = I(.ra_vars())), origin))
    if (path == "/run") return(reply(200L, c(list(ok = TRUE), .rafikiardhi_run(b$code %||% "")), origin))
    if (path == "/plot") {   # redraw a plot at another size or resolution, for the plot window
      rec <- get0("plots", envir = .rafikiardhi, ifnotfound = list())[[as.character(b$id %||% 0)]]
      if (is.null(rec)) return(reply(200L, list(ok = FALSE, error = "That plot can no longer be redrawn. Run its code again."), origin))
      sc <- max(0.5, min(4, as.numeric(b$scale %||% 1))); w <- max(100, min(4000, as.numeric(b$width %||% 720))); h <- max(100, min(4000, as.numeric(b$height %||% 520)))
      f <- tempfile(fileext = ".png")
      res <- tryCatch({
        grDevices::png(f, width = round(w * sc), height = round(h * sc), res = 72 * sc)
        cur <- grDevices::dev.cur(); on.exit(if (cur %in% grDevices::dev.list()) grDevices::dev.off(cur), add = TRUE)
        grDevices::replayPlot(rec); grDevices::dev.off(cur)
        list(ok = TRUE, img = jsonlite::base64_enc(readBin(f, "raw", file.info(f)$size)))
      }, error = function(e) list(ok = FALSE, error = conditionMessage(e)))
      unlink(f)
      return(reply(200L, res, origin))
    }
    if (path == "/data") {
      nm <- make.names(b$name %||% "df")
      res <- tryCatch({
        d <- utils::read.csv(text = b$csv, check.names = TRUE, na.strings = c("", "NA", "#N/A"), stringsAsFactors = FALSE)
        assign(nm, d, envir = globalenv())
        list(ok = TRUE, name = nm, rows = nrow(d), cols = ncol(d), str = utils::capture.output(utils::str(d, give.attr = FALSE, vec.len = 2)))
      }, error = function(e) list(ok = FALSE, error = conditionMessage(e)))
      return(reply(200L, res, origin))
    }
    reply(404L, list(ok = FALSE), origin)
  })
  .rafikiardhi$server <- httpuv::startServer("127.0.0.1", port, app)
  cat("\nRafikiArdhi: R is ready for Excel.\n",
      "  In Excel, open the add-in's R tab, choose \"My R\" and enter this code:  ", token, "\n",
      "  (port ", port, ").  disconnect() ends it.\n\n", sep = "")
  if (!interactive()) { message("Waiting for Excel… (Ctrl+C to stop)"); repeat httpuv::service(100) }
  invisible(token)
}

disconnect <- function(quiet = FALSE) {
  if (!is.null(.rafikiardhi$server)) { try(httpuv::stopServer(.rafikiardhi$server), silent = TRUE); .rafikiardhi$server <- NULL; if (!quiet) cat("RafikiArdhi: disconnected from Excel.\n") }
  invisible(NULL)
}

`%||%` <- function(a, b) if (is.null(a)) b else a