From c70c8950772bde3e25f38d49284be37cc491907b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= <csardi.gabor@gmail.com>
Date: Thu, 23 Nov 2023 13:33:06 +0100
Subject: [PATCH] Avoid jsonlite::toJSON

To help embedding into pak. S4 functions are hard
to handle.
---
 R/advanced_search.R             |   2 +-
 R/api.R                         |   2 +-
 R/tojson.R                      | 107 ++++++++++++++++
 tests/testthat/_snaps/tojson.md | 219 ++++++++++++++++++++++++++++++++
 tests/testthat/test-tojson.R    | 103 +++++++++++++++
 5 files changed, 431 insertions(+), 2 deletions(-)
 create mode 100644 R/tojson.R
 create mode 100644 tests/testthat/_snaps/tojson.md
 create mode 100644 tests/testthat/test-tojson.R

diff --git a/R/advanced_search.R b/R/advanced_search.R
index e104376..d2d26da 100644
--- a/R/advanced_search.R
+++ b/R/advanced_search.R
@@ -79,7 +79,7 @@ advanced_search <- function(..., json = NULL, format = c("short", "long"),
       paste0("(", names(terms), ":", terms, ")")
     )
 
-    qstr <- jsonlite::toJSON(list(
+    qstr <- tojson$write_str(list(
       query = list(
         query_string = list(
           query = jsonlite::unbox(paste0(q, collapse = " AND ")),
diff --git a/R/api.R b/R/api.R
index f855c7e..a56f1de 100644
--- a/R/api.R
+++ b/R/api.R
@@ -177,7 +177,7 @@ make_query <- function(query) {
     )
   )
 
-  jsonlite::toJSON(query_object, auto_unbox = TRUE, pretty = TRUE)
+  tojson$write_str(query_object)
 }
 
 do_query <- function(query, server, port, from, size) {
diff --git a/R/tojson.R b/R/tojson.R
new file mode 100644
index 0000000..2ed842e
--- /dev/null
+++ b/R/tojson.R
@@ -0,0 +1,107 @@
+tojson <- local({
+  map2 <- function(x, y, fn, ...) {
+    mapply(fn, x, y, ..., SIMPLIFY = FALSE)
+  }
+
+  jq <- function(x) {
+    encodeString(x, quote = "\"", justify = "none")
+  }
+
+  comma <- function(x, key = NULL) {
+    len <- length(x)
+    stopifnot(len >= 1)
+
+    if (!is.null(key)) {
+      nokey <- is.na(key) | key == ""
+      key[nokey] <- seq_along(x)[nokey]
+      x <- map2(jq(key), x, function(k, el) {
+        el[1] <- paste0(k, ": ", el[1])
+        el
+      })
+    }
+
+    # No commans needed for scalars
+    if (len == 1) return(x)
+
+    x2 <- lapply(x, function(el) {
+      el[length(el)] <- paste0(el[length(el)], ",")
+      el
+    })
+    x2[[len]] <- x[[len]]
+    x2
+  }
+
+  j_null <- function(x) {
+    "{}"
+  }
+
+  j_list <- function(x) {
+    if (length(x) == 0L) {
+      if (is.null(names(x))) "[]" else "{}"
+
+    } else if (is.null(names(x))) {
+      c("[", paste0("  ", unlist(comma(lapply(x, j)))), "]")
+
+    } else {
+      c("{", paste0("  ", unlist(comma(lapply(x, j), names(x)))), "}")
+    }
+  }
+
+  j_atomic <- function(x) {
+    if (! typeof(x) %in% c("logical", "integer", "double", "character")) {
+      stop("Cannot convert atomic ", typeof(x), " vectors to JSON.")
+    }
+    len <- length(x)
+
+    if (len == 0) {
+      return("[]")
+    }
+
+    if (is.character(x)) {
+      x <- jq(enc2utf8(x))
+    }
+
+    if (is.logical(x)) {
+      x <- tolower(x)
+    }
+
+    if (len == 1L) {
+      if (is.na(x) || x == "NA") "null" else paste0(x)
+
+    } else {
+      x[is.na(x) | x == "NA"] <- "null"
+      paste0("[", paste(comma(x), collapse = " "), "]")
+    }
+}
+
+  j <- function(x) {
+    if (is.null(x)) {
+      j_null(x)
+    } else if (is.list(x)) {
+      j_list(x)
+    } else if (is.atomic(x)) {
+      j_atomic(x)
+    } else {
+      stop("Cannot convert type ", typeof(x), " to JSON.")
+    }
+}
+
+  write_str <- function(x) {
+    paste0(j(x), collapse = "\n")
+  }
+
+  write_file <- function(x, file) {
+    writeLines(j(x), file)
+  }
+
+  write_lines <- function(x) {
+    j(x)
+  }
+
+  list(
+    .envir = environment(),
+    write_str = write_str,
+    write_file = write_file,
+    write_lines = write_lines
+  )
+})
diff --git a/tests/testthat/_snaps/tojson.md b/tests/testthat/_snaps/tojson.md
new file mode 100644
index 0000000..428ed33
--- /dev/null
+++ b/tests/testthat/_snaps/tojson.md
@@ -0,0 +1,219 @@
+# write_str vectors
+
+    Code
+      tojson$write_str(NULL)
+    Output
+      [1] "{}"
+    Code
+      tojson$write_str(list())
+    Output
+      [1] "[]"
+    Code
+      tojson$write_str(integer())
+    Output
+      [1] "[]"
+    Code
+      tojson$write_str(double())
+    Output
+      [1] "[]"
+    Code
+      tojson$write_str(character())
+    Output
+      [1] "[]"
+    Code
+      tojson$write_str(logical())
+    Output
+      [1] "[]"
+
+---
+
+    Code
+      tojson$write_str(complex())
+    Condition
+      Error in `j_atomic()`:
+      ! Cannot convert atomic complex vectors to JSON.
+    Code
+      tojson$write_str(raw())
+    Condition
+      Error in `j_atomic()`:
+      ! Cannot convert atomic raw vectors to JSON.
+
+---
+
+    Code
+      tojson$write_str(list(1))
+    Output
+      [1] "[\n  1\n]"
+    Code
+      tojson$write_str(1L)
+    Output
+      [1] "1"
+    Code
+      tojson$write_str(1)
+    Output
+      [1] "1"
+    Code
+      tojson$write_str("foo")
+    Output
+      [1] "\"foo\""
+    Code
+      tojson$write_str(TRUE)
+    Output
+      [1] "true"
+
+---
+
+    Code
+      tojson$write_str(list(1, 2))
+    Output
+      [1] "[\n  1,\n  2\n]"
+    Code
+      tojson$write_str(1:2)
+    Output
+      [1] "[1, 2]"
+    Code
+      tojson$write_str(c(1, 2))
+    Output
+      [1] "[1, 2]"
+    Code
+      tojson$write_str(c("foo", "bar"))
+    Output
+      [1] "[\"foo\", \"bar\"]"
+    Code
+      tojson$write_str(c(TRUE, FALSE))
+    Output
+      [1] "[true, false]"
+
+---
+
+    Code
+      tojson$write_str(NA_integer_)
+    Output
+      [1] "null"
+    Code
+      tojson$write_str(NA_real_)
+    Output
+      [1] "null"
+    Code
+      tojson$write_str(NA_character_)
+    Output
+      [1] "null"
+    Code
+      tojson$write_str(NA)
+    Output
+      [1] "null"
+
+---
+
+    Code
+      tojson$write_str(c(1L, NA_integer_))
+    Output
+      [1] "[1, null]"
+    Code
+      tojson$write_str(c(1, NA_real_))
+    Output
+      [1] "[1, null]"
+    Code
+      tojson$write_str(c("foo", NA_character_))
+    Output
+      [1] "[\"foo\", null]"
+    Code
+      tojson$write_str(c(TRUE, NA))
+    Output
+      [1] "[true, null]"
+
+---
+
+    Code
+      tojson$write_str(c(a = 1L, b = 2L))
+    Output
+      [1] "[1, 2]"
+    Code
+      tojson$write_str(c(a = 1, b = 2))
+    Output
+      [1] "[1, 2]"
+    Code
+      tojson$write_str(c(a = "foo", b = "bar"))
+    Output
+      [1] "[\"foo\", \"bar\"]"
+    Code
+      tojson$write_str(c(a = TRUE, b = FALSE))
+    Output
+      [1] "[true, false]"
+
+# write_str character encoding and escaping
+
+    Code
+      cat(tojson$write_str("foo\"\\bar"))
+    Output
+      "foo\"\\bar"
+    Code
+      charToRaw(tojson$write_str(iconv(utf8, "UTF-8", "latin1")))
+    Output
+      [1] 22 47 c3 a1 62 6f 72 22
+
+# lists
+
+    Code
+      cat(tojson$write_str(list(list(1, 2, 3), list(4, 5, 6), list(7, 8, 9))))
+    Output
+      [
+        [
+          1,
+          2,
+          3
+        ],
+        [
+          4,
+          5,
+          6
+        ],
+        [
+          7,
+          8,
+          9
+        ]
+      ]
+
+---
+
+    Code
+      cat(tojson$write_str(list(a = 1, b = 2)))
+    Output
+      {
+        "a": 1,
+        "b": 2
+      }
+
+---
+
+    Code
+      cat(tojson$write_str(list(a = list(a1 = 1, a2 = 2), b = list(b1 = 3, b2 = 4))))
+    Output
+      {
+        "a": {
+          "a1": 1,
+          "a2": 2
+        },
+        "b": {
+          "b1": 3,
+          "b2": 4
+        }
+      }
+
+---
+
+    Code
+      cat(tojson$write_str(list(a = list(1, a2 = 2), list(b1 = 3, 4))))
+    Output
+      {
+        "a": {
+          "1": 1,
+          "a2": 2
+        },
+        "2": {
+          "b1": 3,
+          "2": 4
+        }
+      }
+
diff --git a/tests/testthat/test-tojson.R b/tests/testthat/test-tojson.R
new file mode 100644
index 0000000..a483881
--- /dev/null
+++ b/tests/testthat/test-tojson.R
@@ -0,0 +1,103 @@
+test_that("write_str vectors", {
+  # empty vectors
+  expect_snapshot({
+    tojson$write_str(NULL)
+    tojson$write_str(list())
+    tojson$write_str(integer())
+    tojson$write_str(double())
+    tojson$write_str(character())
+    tojson$write_str(logical())
+  })
+
+  # cannot convert some atomic vectors
+  expect_snapshot(error = TRUE, {
+    tojson$write_str(complex())
+    tojson$write_str(raw())
+  })
+
+  # scalars
+  expect_snapshot({
+    tojson$write_str(list(1))
+    tojson$write_str(1L)
+    tojson$write_str(1.0)
+    tojson$write_str("foo")
+    tojson$write_str(TRUE)
+  })
+
+  # vectors
+  expect_snapshot({
+    tojson$write_str(list(1, 2))
+    tojson$write_str(1:2)
+    tojson$write_str(c(1.0, 2.0))
+    tojson$write_str(c("foo", "bar"))
+    tojson$write_str(c(TRUE, FALSE))
+  })
+
+  # NA in vectors
+  expect_snapshot({
+    tojson$write_str(NA_integer_)
+    tojson$write_str(NA_real_)
+    tojson$write_str(NA_character_)
+    tojson$write_str(NA)
+  })
+
+  expect_snapshot({
+    tojson$write_str(c(1L, NA_integer_))
+    tojson$write_str(c(1.0, NA_real_))
+    tojson$write_str(c("foo", NA_character_))
+    tojson$write_str(c(TRUE, NA))
+  })
+
+  # names are ignored
+  expect_snapshot({
+    tojson$write_str(c(a = 1L, b = 2L))
+    tojson$write_str(c(a = 1.0, b = 2.0))
+    tojson$write_str(c(a = "foo", b = "bar"))
+    tojson$write_str(c(a = TRUE, b = FALSE))
+  })
+})
+
+test_that("write_str character encoding and escaping", {
+  utf8 <- "G\u00e1bor"
+  expect_snapshot({
+    cat(tojson$write_str("foo\"\\bar"))
+    charToRaw(tojson$write_str(iconv(utf8, "UTF-8", "latin1")))
+  })
+})
+
+test_that("lists", {
+  # embedded lists
+  expect_snapshot({
+    cat(tojson$write_str(list(list(1, 2, 3), list(4, 5, 6), list(7, 8, 9))))
+  })
+
+  # named lists
+  expect_snapshot({
+    cat(tojson$write_str(list(a = 1, b = 2)))
+  })
+
+  # nested named lists
+  expect_snapshot({
+    cat(tojson$write_str(list(
+        a = list(a1 = 1, a2 = 2),
+        b = list(b1 = 3, b2 = 4)
+    )))
+  })
+
+  # fill in names
+  expect_snapshot({
+    cat(tojson$write_str(list(
+        a = list(1, a2 = 2),
+        list(b1 = 3, 4)
+    )))
+  })
+})
+
+test_that("write_file", {
+  tmp <- tempfile()
+  on.exit(unlink(tmp), add = TRUE)
+
+  tojson$write_file(mtcars, tmp)
+  lns <- tojson$write_lines(mtcars)
+  expect_equal(readLines(tmp), lns)
+})
\ No newline at end of file