diff --git a/sess/R/dispatch.R b/sess/R/dispatch.R index 1d9e6759..3a626cf0 100644 --- a/sess/R/dispatch.R +++ b/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( { diff --git a/sess/R/handlers.R b/sess/R/handlers.R index e0da8a44..6dec46e2 100644 --- a/sess/R/handlers.R +++ b/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]]) } } } diff --git a/sess/inst/tinytest/test-dataview.R b/sess/inst/tinytest/test-dataview.R new file mode 100644 index 00000000..82e7fe2d --- /dev/null +++ b/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) + } +}) diff --git a/sess/inst/tinytest/test-ipc.R b/sess/inst/tinytest/test-ipc.R index 1482e106..072bc3d1 100644 --- a/sess/inst/tinytest/test-ipc.R +++ b/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.