From fb283f59316ea7524a4523a59e1fe0060c972a1d Mon Sep 17 00:00:00 2001
From: Chris Jackson <chris.jackson@mrc-bsu.cam.ac.uk>
Date: Thu, 24 Aug 2023 10:39:12 +0100
Subject: [PATCH] Test survrtrunc, exclude fracpoly

---
 R/fracpoly.R                 |  2 ++
 tests/testthat/test_rtrunc.R | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 38 insertions(+)

diff --git a/R/fracpoly.R b/R/fracpoly.R
index b9d9e6a..d2991f5 100644
--- a/R/fracpoly.R
+++ b/R/fracpoly.R
@@ -1,5 +1,6 @@
 ### simplified version of gamlss::bfp with no shift or scale
 
+#nocov start
 bfp <- function (x, powers = c(1, 2)) 
 {
     nobs <- length(x)
@@ -45,3 +46,4 @@ dbfp <- function (x, powers = c(1, 2))
     }
     X
 }
+#nocov end
diff --git a/tests/testthat/test_rtrunc.R b/tests/testthat/test_rtrunc.R
index d56cf66..af9fa1c 100644
--- a/tests/testthat/test_rtrunc.R
+++ b/tests/testthat/test_rtrunc.R
@@ -42,3 +42,39 @@ test_that("summary.flexsurvtrunc works", {
   expect_equal(summse$se, 0.004329825)
 })
 
+
+test_that("survrtrunc works", {
+  ## simulate some event time data
+  set.seed(1)
+  X <- rweibull(100, 2, 10)
+  T <- rweibull(100, 2, 10)
+
+  ## truncate above
+  tmax <- 20
+  obs <- X + T < tmax
+  rtrunc <- tmax - X
+  dat <- data.frame(X, T, rtrunc)[obs,]
+  
+  sf <-    survrtrunc(T, rtrunc, data=dat, tmax=tmax)
+  sfnaive <- survfit(Surv(T) ~ 1, data=dat)
+  ## Kaplan-Meier estimate ignoring truncation is biased
+  expect_true(all(sf$surv[10:20] > sfnaive$surv[10:20]))
+
+  if (interactive() || covr::in_covr()){
+    plot(sf, conf.int=TRUE)
+    lines(sfnaive, conf.int=TRUE, lty=2, col="red")
+    plot(sfnaive, conf.int=TRUE)
+    lines(sf, conf.int=TRUE, lty=2, col="red")
+  }
+
+  ## truncate above the maximum observed time
+  tmax <- max(X + T) + 10
+  obs <- X + T < tmax
+  rtrunc <- tmax - X
+  dat <- data.frame(X, T, rtrunc)[obs,]
+  sf <-    survrtrunc(T, rtrunc, data=dat, tmax=tmax)
+  ## estimates identical to the standard Kaplan-Meier
+  sfnaive <- survfit(Surv(T) ~ 1, data=dat)
+
+  expect_equal(sf$surv[1:10], sfnaive$surv[1:10])
+})