work with gam

seroanalytics · Sep 16, 2024 · bc4346b · bc4346b
1 parent a6096dd
commit bc4346b
Show file tree

Hide file tree

Showing 3 changed files with 43 additions and 2 deletions.
diff --git a/R/api.R b/R/api.R
@@ -195,12 +195,13 @@ model_out <- function(dat, xcol,
   if (n == 0) {
     return(list(x = list(), y = list()))
   }
+  dat[, xcol] <- as.numeric(dat[, xcol])
   if ((n > 1000 && method == "auto") || method == "gam") {
     fmla <- sprintf("value ~ s(%s, bs   = 'cs', k = %f)", xcol, k)
     m <- mgcv::gam(eval(parse(text = fmla)),
                    data = dat, method = "REML")
   } else {
-    fmla <- sprintf("value ~ as.numeric(%s)", xcol)
+    fmla <- sprintf("value ~ %s", xcol)
     m <- stats::loess(fmla, data = dat, span = span)
   }
   range <- range(dat[, xcol], na.rm = TRUE)

diff --git a/tests/testthat/test-dates.R b/tests/testthat/test-dates.R
@@ -81,3 +81,25 @@ test_that("y/d/m", {
   data <- body$data
   expect_equal(unlist(data$raw[1, "x"]), rep(c("2024-01-14", "2024-01-15"), 5))
 })
+
+test_that("using gam", {
+  router <- build_routes(cookie_key)
+  dates <- sapply(1:50, function(x) format(as.Date(2 * x, origin = "2023-01-01")))
+  request <- local_POST_dataset_request(data.frame(biomarker = "ab",
+                                                   day = dates,
+                                                   value = 1:10),
+                                        "testdataset",
+                                        cookie = cookie)
+  upload_res <- router$call(request)
+  expect_equal(upload_res$status, 200)
+
+  res <- router$call(make_req("GET",
+                              "/dataset/testdataset/trace/ab/",
+                              qs = "method=gam",
+                              HTTP_COOKIE = cookie))
+
+  expect_equal(res$status, 200)
+  body <- jsonlite::fromJSON(res$body)
+  data <- body$data
+  expect_equal(unlist(data$raw[1, "x"]), dates)
+})
diff --git a/tests/testthat/test-model.R b/tests/testthat/test-model.R
@@ -67,7 +67,7 @@ test_that("model uses loess options", {
   expect_true(all(res$y == expected))
 })
 
-test_that("model can handle dates", {
+test_that("loess model can handle dates", {
   dates <- sapply(1:50, function(x) as.Date(2 * x, origin = "2023-01-01"))
   full_range <- sapply(2:100, function(x) as.Date(x, origin = "2023-01-01"))
   dat <- data.frame(date = dates, value = rnorm(50))
@@ -82,3 +82,21 @@ test_that("model can handle dates", {
   expect_equal(res$x[2], "2023-01-04")
   expect_equal(res$x[99], "2023-04-11")
 })
+
+
+test_that("gam model can handle dates", {
+  dates <- sapply(1:50, function(x) as.Date(2 * x, origin = "2023-01-01"))
+  full_range <- sapply(2:100, function(x) as.Date(x, origin = "2023-01-01"))
+  dat <- data.frame(date = dates, value = rnorm(50))
+  res <- model_out(dat, xcol = "date", xtype = "date", method = "gam")
+
+  m <- mgcv::gam(value ~ s(date, bs   = 'cs'),
+                 data = dat, method = "REML")
+  xdf <- tibble::tibble(date = full_range)
+  expected <- stats::predict(m, xdf)
+
+  expect_true(all(res$y == expected))
+  expect_equal(res$x[1], "2023-01-03")
+  expect_equal(res$x[2], "2023-01-04")
+  expect_equal(res$x[99], "2023-04-11")
+})