Fix/data viewer display

sess/R/dispatch.R

@@ -4,7 +4,7 @@ ipc_write <- function(data) {
   con <- .sess_env$con
   if (is.null(con)) return(invisible(FALSE))
 
-  json <- jsonlite::toJSON(data, auto_unbox = TRUE, null = "null", force = TRUE)
+  json <- jsonlite::toJSON(data, auto_unbox = TRUE, null = "null", force = TRUE, digits = NA)
   line <- c(charToRaw(enc2utf8(json)), as.raw(0x0a))
   tryCatch(
     {

sess/R/handlers.R

@@ -339,7 +339,7 @@ get_column_def <- function(name, field, value) {
     }
     type <- "bigintColumn"
     filter <- "agBigIntColumnFilter"
-  } else if (is.numeric(value)) {
+  } else if (is.numeric(value) && !is.object(value)) {
     type <- "numericColumn"
     filter <- "agNumberColumnFilter"
   } else if (inherits(value, "Date")) {
@@ -349,7 +349,7 @@ get_column_def <- function(name, field, value) {
                inherits(value, "POSIXlt")) {
     type <- "datetimeColumn"
     filter <- "agDateColumnFilter"
-  } else if (is.logical(value)) {
+  } else if (is.logical(value) && !is.object(value)) {
     type <- "booleanColumn"
     filter <- TRUE
   } else {
@@ -374,7 +374,7 @@ get_column_def <- function(name, field, value) {
     filter = jsonlite::unbox(filter),
     sortable = jsonlite::unbox(sortable)
   )
-  if (is.logical(value)) {
+  if (identical(type, "booleanColumn")) {
     col_def$cellDataType <- jsonlite::unbox("boolean")
   }
   if (identical(field, "0")) {
@@ -541,6 +541,30 @@ dataview_column_values <- function(state, position, row_idx = NULL) {
   if (is.null(row_idx)) values else values[row_idx]
 }
 
+dataview_format_column <- function(values) {
+  if (!is.object(values) || !is.null(dim(values))) {
+    return(values)
+  }
+
+  # Let the class supply its display, without changing the stored values used for sorting.
+  formatted <- tryCatch(
+    format(values, trim = TRUE, justify = "none"),
+    error = function(e) NULL
+  )
+  if (!is.character(formatted) || !is.null(dim(formatted)) ||
+        length(formatted) != length(values)) {
+    formatted <- tryCatch(as.character(values), error = function(e) NULL)
+  }
+  if (!is.character(formatted) || !is.null(dim(formatted)) ||
+        length(formatted) != length(values)) {
+    return(values)
+  }
+  tryCatch({
+    formatted[is.na(values)] <- NA_character_
+    formatted
+  }, error = function(e) values)
+}
+
 dataview_match_condition <- function(values, cond) {
   if (is.null(cond$type)) {
     return(rep(TRUE, length(values)))
@@ -674,6 +698,9 @@ dataview_apply_filter_model <- function(state, filter_model, row_idx) {
     }
 
     values <- dataview_column_values(state, col_pos, row_idx)
+    if (state$columns[[col_pos]]$type == "textColumn") {
+      values <- dataview_format_column(values)
+    }
     column_match <- dataview_filter_values(values, col_model)
     column_match[is.na(column_match)] <- FALSE
     matched <- matched & column_match
@@ -748,7 +775,8 @@ dataview_query_key <- function(sort_model, filter_model) {
     ),
     auto_unbox = TRUE,
     null = "null",
-    force = TRUE
+    force = TRUE,
+    digits = NA
   )
 }
 
@@ -772,6 +800,8 @@ dataview_rows <- function(state, row_idx) {
         page[[position]] <- format(page[[position]], "%Y-%m-%dT%H:%M:%S")
       } else if (inherits(page[[position]], "integer64")) {
         page[[position]] <- as.character(page[[position]])
+      } else if (state$columns[[position + 1L]]$type == "textColumn") {
+        page[[position]] <- dataview_format_column(page[[position]])
       }
     }
   }

sess/inst/tinytest/test-dataview.R

@@ -0,0 +1,81 @@
+# Small numbers survive the actual JSON response and remain distinct in cached filters.
+local({
+  .sess_env <- sess:::.sess_env
+  orig_dataviews <- .sess_env$dataviews
+  orig_con <- .sess_env$con
+  pipe <- processx::conn_create_pipepair()
+  on.exit({
+    .sess_env$dataviews <- orig_dataviews
+    .sess_env$con <- orig_con
+    lapply(pipe, close)
+  }, add = TRUE)
+  .sess_env$con <- pipe[[2L]]
+
+  values <- c(1.54e-05, 3.54e-05, -6.65e-13, 1.54e-100, 0, 1.23456789)
+  registration <- sess:::dataview_register(data.frame(value = values))
+  page <- sess:::handle_dataview_page(list(view_id = registration$view_id))
+  sess:::rpc_reply("page", page)
+  response <- jsonlite::fromJSON(processx::conn_read_chars(pipe[[1L]]))
+  actual <- response$result$rows[["1"]]
+  expect_length(actual, length(values))
+  expect_true(all(abs(actual - values) <= abs(values) * 1e-14))
+
+  for (value in values[1:2]) {
+    filtered <- sess:::handle_dataview_page(list(
+      view_id = registration$view_id,
+      filterModel = list("1" = list(type = "equals", filter = value))
+    ))
+    expect_equal(filtered$rows[["1"]], value, tolerance = 1e-14)
+  }
+})
+
+# S3 and S4 numeric subclasses supply their own display and text-filter values.
+local({
+  registerS3method("[", "dataview_test", function(x, ...) {
+    structure(NextMethod(), class = class(x))
+  })
+  class_env <- environment()
+  methods::setClass("dataview_s4_test", contains = "numeric", where = class_env)
+  on.exit({
+    methods::removeMethod("[", "dataview_s4_test", where = class_env)
+    methods::removeClass("dataview_s4_test", where = class_env)
+    rm(
+      list = c("[.dataview_test", "format.dataview_test", "format.dataview_s4_test"),
+      envir = get(".__S3MethodsTable__.", envir = asNamespace("base"))
+    )
+  }, add = TRUE)
+  methods::setMethod("[", "dataview_s4_test", function(x, i, j, ..., drop = TRUE) {
+    methods::new("dataview_s4_test", as.numeric(x)[i])
+  }, where = class_env)
+  for (class_name in c("dataview_test", "dataview_s4_test")) {
+    registerS3method("format", class_name, function(x, ...) {
+      paste0("value:", as.numeric(x))
+    })
+  }
+
+  values <- c(20, 2, 10, NA_real_)
+  cases <- list(
+    S3 = structure(values, class = "dataview_test"),
+    S4 = methods::new("dataview_s4_test", values)
+  )
+  for (case_name in names(cases)) {
+    df <- data.frame(id = 1:4)
+    df$value <- cases[[case_name]]
+    expect_equal(isS4(df$value), case_name == "S4", info = case_name)
+    expect_true(is.numeric(df$value), info = case_name)
+    expect_true(is.object(df$value), info = case_name)
+
+    state <- sess:::dataview_to_state(df)
+    expect_equal(as.character(state$columns[[3L]]$type), "textColumn", info = case_name)
+    expect_equal(
+      as.character(state$columns[[3L]]$filter), "agTextColumnFilter", info = case_name
+    )
+    expect_equal(
+      sess:::dataview_rows(state, 1:4)[["2"]],
+      c("value:20", "value:2", "value:10", NA_character_), info = case_name
+    )
+    expect_equal(sess:::dataview_query_indices(
+      state, NULL, list("2" = list(type = "equals", filter = "value:2"))
+    ), 2L, info = case_name)
+  }
+})

sess/inst/tinytest/test-ipc.R

@@ -70,32 +70,47 @@ local({
 local({
   .sess_env <- sess:::.sess_env
   orig_dataviews <- .sess_env$dataviews
-  on.exit(.sess_env$dataviews <- orig_dataviews, add = TRUE)
+  orig_con <- .sess_env$con
+  pipe <- processx::conn_create_pipepair()
+  on.exit({
+    .sess_env$dataviews <- orig_dataviews
+    .sess_env$con <- orig_con
+    lapply(pipe, close)
+  }, add = TRUE)
+  .sess_env$con <- pipe[[2L]]
 
   .sess_env$dataviews <- list()
 
-  df <- data.frame(a = c(3, 1, 2), b = c("x", "y", "z"), stringsAsFactors = FALSE)
+  df <- data.frame(
+    a = c(1.54e-03, 1.54e-04, 1.54e-05, 1.54e-06, 6.65e-13, 1.54e-100,
+          -1.54e-05, 0, 1.23456789, 42),
+    b = letters[1:10]
+  )
   registration <- sess:::dataview_register(df)
 
   expect_true(is.character(registration$view_id))
-  expect_equal(registration$total_rows, 3)
+  expect_equal(registration$total_rows, nrow(df))
   expect_length(registration$columns, 3)
 
   init_res <- sess:::handle_dataview_init(list(view_id = registration$view_id))
-  expect_equal(init_res$totalRows, 3)
+  expect_equal(init_res$totalRows, nrow(df))
   expect_length(init_res$columns, 3)
 
   page_res <- sess:::handle_dataview_page(list(
     view_id = registration$view_id,
     startRow = 0L,
-    endRow = 2L,
+    endRow = nrow(df) - 1L,
     sortModel = list(),
     filterModel = list()
   ))
 
-  expect_equal(length(page_res$rows), 2)
-  expect_equal(page_res$rows[[1]][["1"]], "3")
-  expect_equal(page_res$rows[[2]][["1"]], "1")
+  expected <- head(df$a, -1L)
+  expect_equal(nrow(page_res$rows), nrow(df) - 1L)
+  expect_equal(page_res$rows[["1"]], expected)
+
+  sess:::rpc_reply("page", page_res)
+  response <- jsonlite::fromJSON(processx::conn_read_chars(pipe[[1L]]))
+  expect_true(all(abs(response$result$rows[["1"]] - expected) <= abs(expected) * 1e-14))
 
   disposed <- sess:::handle_dataview_dispose(list(view_id = registration$view_id))
   expect_true(isTRUE(disposed))
@@ -113,7 +128,7 @@ local({
 
   .sess_env$dataviews <- list()
 
-  df <- data.frame(a = c(10, 30, 20), b = c("apple", "banana", "berry"), stringsAsFactors = FALSE)
+  df <- data.frame(a = c(1.54e-05, 3.54e-05, 2.54e-05), b = c("apple", "banana", "berry"))
   registration <- sess:::dataview_register(df)
 
   filtered <- sess:::handle_dataview_page(list(
@@ -127,9 +142,8 @@ local({
   ))
 
   expect_equal(filtered$totalRows, 2)
-  expect_equal(length(filtered$rows), 2)
-  expect_equal(filtered$rows[[1]][["2"]], "banana")
-  expect_equal(filtered$rows[[2]][["2"]], "berry")
+  expect_equal(nrow(filtered$rows), 2)
+  expect_equal(filtered$rows[["2"]], c("banana", "berry"))
 
   sorted <- sess:::handle_dataview_page(list(
     view_id = registration$view_id,
@@ -142,9 +156,17 @@ local({
   ))
 
   expect_equal(sorted$totalRows, 3)
-  expect_equal(sorted$rows[[1]][["1"]], "30")
-  expect_equal(sorted$rows[[2]][["1"]], "20")
-  expect_equal(sorted$rows[[3]][["1"]], "10")
+  expect_equal(sorted$rows[["1"]], sort(df$a, decreasing = TRUE))
+
+  for (value in df$a[1:2]) {
+    filtered <- sess:::handle_dataview_page(list(
+      view_id = registration$view_id,
+      filterModel = list(
+        "1" = list(filterType = "number", type = "equals", filter = value)
+      )
+    ))
+    expect_equal(filtered$rows[["1"]], value, tolerance = 1e-14)
+  }
 })
 
 # NDJSON framing round-trips correctly through a socket pair.