diff --git a/R/api.R b/R/api.R index 024158a..4986229 100644 --- a/R/api.R +++ b/R/api.R @@ -205,32 +205,14 @@ target_get_individual <- function(req, } dat <- apply_filters(dat, filter) - if (is.null(color)) { - if (is.null(linetype)) { - aes <- ggplot2::aes(x = .data[[xcol]], y = value) - } else { - aes <- ggplot2::aes(x = .data[[xcol]], y = value, - linetype = .data[[linetype]]) - } - } else { - if (is.null(linetype)) { - aes <- ggplot2::aes(x = .data[[xcol]], y = value, - color = .data[[color]]) - } else { - aes <- ggplot2::aes(x = .data[[xcol]], y = value, - color = .data[[color]], - linetype = .data[[linetype]]) - } - } + aes <- get_aes(color, linetype, xcol) warnings <- NULL ids <- unique(dat[[pidcol]]) - if (length(ids) > 20) { - msg <- paste(length(ids), - "individuals identified; only the first 20 will be shown.") - warnings <- c(warnings, msg) - dat <- dat[dat[[pidcol]] %in% ids[1:20], ] - } + page_length <- 20 + num_pages <- ceiling(length(ids) / page_length) + paged_ids <- get_paged_ids(ids, page, page_length) + dat <- dat[dat[[pidcol]] %in% paged_ids, ] # Facets in plotlyjs are quite a pain. Using ggplot2 and plotly R # packages to generate the plotly data and layout objects is a bit slower @@ -249,10 +231,39 @@ target_get_individual <- function(req, jsonlite::toJSON( list(data = as.list(q$x$data), layout = as.list(q$x$layout), + page = page, + numPages = num_pages, warnings = warnings), auto_unbox = TRUE, null = "null") } +get_paged_ids <- function(ids, current_page, page_length) { + page_start <- ((current_page - 1) * page_length) + 1 + page_end <- min(length(ids), page_start + (page_length - 1)) + ids[page_start:page_end] +} + +get_aes <- function(color, linetype, xcol) { + if (is.null(color)) { + if (is.null(linetype)) { + aes <- ggplot2::aes(x = .data[[xcol]], y = value) + } else { + aes <- ggplot2::aes(x = .data[[xcol]], y = value, + linetype = .data[[linetype]]) + } + } else { + if (is.null(linetype)) { + aes <- ggplot2::aes(x = .data[[xcol]], y = value, + color = .data[[color]]) + } else { + aes <- ggplot2::aes(x = .data[[xcol]], y = value, + color = .data[[color]], + linetype = .data[[linetype]]) + } + } + return(aes) +} + read_dataset <- function(req, name, scale) { validate_scale(scale) session_id <- get_or_create_session_id(req) diff --git a/R/router.R b/R/router.R index e269ade..dc41e75 100644 --- a/R/router.R +++ b/R/router.R @@ -119,7 +119,8 @@ get_individual <- function() { porcelain::porcelain_input_query(scale = "string", color = "string", filter = "string", - linetype = "string"), + linetype = "string", + page = "numeric"), returning = porcelain::porcelain_returning_json("Plotly")) } diff --git a/inst/schema/Plotly.schema.json b/inst/schema/Plotly.schema.json index 552dbfb..aa7e68d 100644 --- a/inst/schema/Plotly.schema.json +++ b/inst/schema/Plotly.schema.json @@ -26,8 +26,14 @@ "items": { "type": "string" } + }, + "numPages": { + "type": "number" + }, + "page": { + "type": "number" } }, - "required": ["data", "layout", "warnings"], + "required": ["data", "layout", "warnings", "numPages", "page"], "additionalProperties": false } diff --git a/tests/testthat/test-paging.R b/tests/testthat/test-paging.R new file mode 100644 index 0000000..bba9151 --- /dev/null +++ b/tests/testthat/test-paging.R @@ -0,0 +1,71 @@ +test_that("page 1 is first n ids if n < length(ids)", { + ids <- c("a", "b", "c", "d", "e") + result <- get_paged_ids(ids, 1, 2) + expect_equal(result, c("a", "b")) +}) + +test_that("page 1 is all ids if n >= length(ids)", { + ids <- c("a", "b", "c", "d", "e") + result <- get_paged_ids(ids, 1, 10) + expect_equal(result, ids) +}) + +test_that("page 2 is second n ids", { + ids <- c("a", "b", "c", "d", "e") + result <- get_paged_ids(ids, 2, 2) + expect_equal(result, c("c", "d")) +}) + +test_that("last page is last m ids where m <= n", { + ids <- c("a", "b", "c", "d", "e") + result <- get_paged_ids(ids, 3, 2) + expect_equal(result, c("e")) +}) + +test_that("first page of results returned by default", { + dat <- data.frame(biomarker = "ab", + pid = 1:25, + value = 1, + day = 1:25) + router <- build_routes(cookie_key) + post_request <- local_POST_dataset_request(dat, + "testdataset", + cookie = cookie) + expect_equal(router$call(post_request)$status, 200) + res <- router$call(make_req("GET", + "/dataset/testdataset/individual/pid/", + HTTP_COOKIE = cookie)) + + expect_equal(res$status, 200) + + body <- jsonlite::fromJSON(res$body) + expect_equal(body$data$page, 1) + expect_equal(body$data$numPages, 2) + + data <- body$data$data + expect_equal(nrow(data), 20) +}) + +test_that("correct page of results returned", { + dat <- data.frame(biomarker = "ab", + pid = 1:25, + value = 1, + day = 1:25) + router <- build_routes(cookie_key) + post_request <- local_POST_dataset_request(dat, + "testdataset", + cookie = cookie) + expect_equal(router$call(post_request)$status, 200) + res <- router$call(make_req("GET", + "/dataset/testdataset/individual/pid/", + qs = "page=2", + HTTP_COOKIE = cookie)) + + expect_equal(res$status, 200) + body <- jsonlite::fromJSON(res$body) + expect_equal(body$data$page, 2) + expect_equal(body$data$numPages, 2) + + data <- body$data$data + expect_equal(nrow(data), 5) +}) diff --git a/tests/testthat/test-read-individual.R b/tests/testthat/test-read-individual.R index 372dd9b..43a0416 100644 --- a/tests/testthat/test-read-individual.R +++ b/tests/testthat/test-read-individual.R @@ -213,25 +213,3 @@ test_that("can get dataset with dates", { expect_equal(unlist(data[1, "x"]), as.numeric(lubridate::ydm(dates))) expect_equal(unlist(data[1, "y"]), 1:5) }) - -test_that("only first 20 individuals are returned", { - dat <- data.frame(biomarker = "ab", - pid = 1:25, - value = 1, - day = 1:25) - router <- build_routes(cookie_key) - post_request <- local_POST_dataset_request(dat, - "testdataset", - cookie = cookie) - expect_equal(router$call(post_request)$status, 200) - res <- router$call(make_req("GET", - "/dataset/testdataset/individual/pid/", - HTTP_COOKIE = cookie)) - expect_equal(res$status, 200) - body <- jsonlite::fromJSON(res$body) - warnings <- body$data$warnings - expect_equal(warnings, "25 individuals identified; only the first 20 will be shown.") - - data <- body$data$data - expect_equal(nrow(data), 20) -})