version 0.1-2

DESCRIPTION

@@ -0,0 +1,19 @@
+Package: npcure
+Version: 0.1-2
+Date: 2019-05-06
+Title: Nonparametric Estimation in Mixture Cure Models
+Authors@R: c(person("Ignacio", "López-de-Ullibarri", role = c("aut", "cre"), email = "ignacio.lopezdeullibarri@udc.es"), person("Ana", "López-Cheda", role = "aut", email = "ana.lopez.cheda@udc.es"), person("Maria Amalia", "Jácome", role = "aut", email = "majacome@udc.es"))
+Author: Ignacio López-de-Ullibarri [aut, cre],
+  Ana López-Cheda [aut],
+  Maria Amalia Jácome [aut]
+Maintainer: Ignacio López-de-Ullibarri <ignacio.lopezdeullibarri@udc.es>
+Depends: R (>= 3.5.0)
+Suggests: KMsurv
+Description: Performs nonparametric estimation in mixture cure models, and significance tests for the cure probability. For details, see López-Cheda et al. (2017a) <doi:10.1016/j.csda.2016.08.002> and López-Cheda et al. (2017b) <doi:10.1007/s11749-016-0515-1>.
+License: GPL (>= 2)
+Imports: permute, stats, utils, zoo
+NeedsCompilation: yes
+Encoding: UTF-8
+Packaged: 2019-05-06 09:03:37 UTC; ilu
+Repository: CRAN
+Date/Publication: 2019-05-08 10:40:10 UTC

MD5

@@ -0,0 +1,30 @@
+f8b31e1b0447af4d0918bc6cc0d98b51 *DESCRIPTION
+ca0b5880aef80b5d62f77d5fcd52890c *NAMESPACE
+5e64f650435820f35945a975d47a72d9 *R/beran.R
+6f8ab7b49473f235d7e9f673a9dac8dc *R/hselect.R
+74fb6cda7f2a4a912e28336281548b32 *R/latency.R
+d450a70211b8f7582956b0de0bcc61e2 *R/pilot.R
+0abbda2154ed2931a1f745db03930954 *R/print.R
+e7afca6c51e00e6f2281ff78c6d0cf74 *R/probcure.R
+c1160db72822a4c60c82744e13051aa8 *R/tests.R
+3fceda06887e07c8dad8cc0d0eb65e28 *build/partial.rdb
+6de4b89bc2acf360d187ddcb3278c97f *man/beran.Rd
+2baee4ff4a6709f71fef593273feb309 *man/berancv.Rd
+b10fbd680c2f4ebe152cdce170b86ee7 *man/controlpars.Rd
+e1018e3eb918bba253241e0dd41b4110 *man/hpilot.Rd
+4ce36247631a87e8fef990a38da9378f *man/latency.Rd
+46b997cc58ff23d094ddef041a2d884c *man/latencyhboot.Rd
+517aac063f9d07b25996229c870ebeb5 *man/npcure-package.Rd
+64b59c8d8f0efd4ea3dd951cdd164f6a *man/print.npcure.Rd
+913683bef3cec21bebd992c8a725f240 *man/probcure.Rd
+ecfdf7404c1db2eb20ce0c7812887a15 *man/probcurehboot.Rd
+3ae086eda2f606dd9d0dacd2404d42f7 *man/summary.npcure.Rd
+eafc1cf00dd604a17662a94eadbd7cd9 *man/testcov.Rd
+d08a45a91acc13af7ed0146435fdacf8 *man/testmz.Rd
+35e5f189837499f0b240cdf8d6a2fc8d *src/beran.c
+4ae3207e81891281e8f3d5efea165c6b *src/boot.c
+f42d6fa2bbcfec03bf6b431a041d4394 *src/cv.c
+44e1e4f8be02f7c159062bc66f08c7ce *src/latency.c
+6a374c7266699ea81cd4c9a44a496089 *src/npcure.h
+05f46e7a9b2202e1898fbd769bfc75fb *src/npcure_init.c
+da46627d973e96c4ca0bfab0e3d693fc *src/probcure.c

NAMESPACE

@@ -0,0 +1,17 @@
+useDynLib(npcure, .registration = TRUE)
+
+S3method(print, npcure)
+
+S3method(summary, npcure)
+
+import("stats")
+
+importFrom("permute", "allPerms")
+
+importFrom("utils", "str")
+
+importFrom("utils", "tail")
+
+importFrom("zoo", "rollapply")
+
+export(beran, berancv, controlpars, hpilot, latency, latencyhboot, probcure, probcurehboot, testcov, testmz)

R/beran.R

@@ -0,0 +1,122 @@
+## Beran's estimator of conditional survival function
+beran <- function(x,
+                  t,
+                  d,
+                  dataset,
+                  x0,
+                  h,
+                  local = TRUE,
+                  testimate = NULL,
+                  conflevel = 0L,
+                  cvbootpars = if (conflevel == 0 && !missing(h)) NULL else npcure::controlpars()) {
+    dfr <-
+        if (missing(dataset))
+            na.omit(data.frame(x, t, d))
+        else 
+            na.omit(dataset[, c(deparse(substitute(x)), deparse(substitute(t)), deparse(substitute(d)))])
+    names(dfr) <- c("x", "t", "d")
+    dfr$x <- as.numeric(dfr$x)
+    dfr$t <- as.numeric(dfr$t)
+    dfr$d <- as.integer(dfr$d)
+    nrow <- dim(dfr)[1]
+    ordx0 <- order(x0)
+    x0 <- as.numeric(x0[ordx0])
+    lx0 <- length(x0)
+    if (missing(h)) {
+        sm <- cvbootpars$hsmooth
+        h <-
+            if (sm > 1)
+                npcure::berancv(x, t, d, dfr, x0, cvbootpars)$hsmooth
+            else
+                npcure::berancv(x, t, d, dfr, x0, cvbootpars)$h
+    }
+    else {
+        if (local) {
+            if (lx0 != length(h)) stop("When 'local = TRUE', 'x0' and 'h' must have the same length")
+            h <- as.numeric(h[ordx0])
+        }
+        else {
+            h <- as.numeric(h)
+        }
+    }
+    lh <- length(h)
+    dfr <- dfr[order(dfr$t, 1 - dfr$d),]
+    if (conflevel < 0 | conflevel > 1) stop("'conflevel' must be a number between 0 and 1")
+    ltestimate <- length(testimate)
+    if (!is.null(testimate)) {
+        if (conflevel == 0)
+            warning("When 'testimate' is not NULL don't use the survival estimates for plotting")
+        else
+            stop("For plotting confidence bands 'testimate' must be NULL")
+        testimate <- as.numeric(testimate)
+    }
+    S <- .Call("berannp0",
+               dfr$t,
+               dfr$x,
+               dfr$d,
+               nrow,
+               x0,
+               lx0,
+               h,
+               lh,
+               local,
+               testimate,
+               ltestimate,
+               PACKAGE = "npcure")
+    if (local) { 
+        names(S) <- paste("x", as.character(round(x0, 8)), sep = "")
+    }
+    else {
+        names(S) <- paste("h", as.character(round(h, 8)), sep = "")  
+        for (i in 1:lh) {
+            if (lx0 == 1)
+                S[[i]] <- list(S[[i]])
+            names(S[[i]]) <- paste("x", as.character(round(x0, 8)), sep = "")
+        }
+    }
+    if (conflevel > 0) {
+        B <- cvbootpars$B
+        fpilot <- cvbootpars$fpilot
+        if (is.null(fpilot)) {
+            pilot <- npcure::hpilot(dfr$x, dfr$x, cvbootpars$nnfrac)
+        }
+        else
+            pilot <- do.call(fpilot, c(list(x0 = dfr$x), cvbootpars$dots))
+        probcurepilot <- as.numeric(npcure::probcure(x, t, d, dfr, dfr$x, pilot)$q)
+        band <- .Call("berannp0confband",
+                      dfr$t,
+                      dfr$x,
+                      dfr$d,
+                      nrow,
+                      x0,
+                      lx0,
+                      h,
+                      lh,
+                      pilot,
+                      probcurepilot,
+                      1 - (1 - conflevel)/2,
+                      B,
+                      S,
+                      local,
+                      PACKAGE = "npcure")
+        if (local) {
+            names(band) <- paste("x", as.character(round(x0, 8)), sep = "")
+            for (i in 1:lx0) {
+                names(band[[i]]) <- c("lower", "upper")
+            }
+        }
+        else {
+            names(band) <- paste("h", as.character(round(h, 8)), sep = "")
+            for (i in 1:lh) {
+                names(band[[i]]) <- paste("x", as.character(round(x0, 8)), sep = "")
+                for (j in 1:lx0) {
+                    names(band[[i]][[j]]) <- c("lower", "upper")
+                }
+            }
+        }
+        structure(list(type = "survival", local = local, h = h, x0 = x0, testim = dfr$t, S = S, conf = band, conflevel = conflevel), class = "npcure")
+    }
+    else {
+        structure(list(type = "survival", local = local, h = h, x0 = x0, testim = if (is.null(testimate)) dfr$t else testimate, S = S), class = "npcure")
+    }
+}

R/hselect.R

@@ -0,0 +1,189 @@
+## Function for setting control parameters
+controlpars <- function(B = 999L,
+                        hbound = c(0.1, 3),
+                        hl = 100L,
+                        hsave = FALSE,
+                        nnfrac = 0.25,
+                        fpilot = NULL,
+                        qt = 0.75,
+                        hsmooth = 1L,
+                        ...) {
+    if (length(hbound) != 2 || any(hbound <= 0))
+        stop("Incorrect 'hbound' parameter")
+    if (hl < 1)
+        stop("Incorrect 'hl' parameter")
+    if (nnfrac <= 0 || nnfrac >= 1)
+        stop("Incorrect 'nnfrac' parameter")
+    if (qt <= 0 || nnfrac >= 1)
+        stop("Incorrect 'qt' parameter")
+    if (hsmooth < 1)
+        stop("Incorrect 'hsmooth' parameter")
+    list(B = as.integer(B), hbound = as.numeric(hbound), hl = as.integer(hl), hsave = hsave, nnfrac = nnfrac, fpilot = fpilot, qt = qt, hsmooth = as.integer(hsmooth), dots = list(...))
+}
+
+## Bootstrap bandwidth selector for the estimator of cure probability
+probcurehboot <- function(x,
+                          t,
+                          d,
+                          dataset,
+                          x0,
+                          bootpars = npcure::controlpars()) {
+    dfr <-
+        if (missing(dataset))
+            na.omit(data.frame(x, t, d))
+        else 
+            na.omit(dataset[, c(deparse(substitute(x)), deparse(substitute(t)), deparse(substitute(d)))])
+    names(dfr) <- c("x", "t", "d")
+    dfr$x <- as.numeric(dfr$x)
+    dfr$t <- as.numeric(dfr$t)
+    dfr$d <- as.integer(dfr$d)
+    dfr <- dfr[order(dfr$t, 1 - dfr$d),]
+    x0 <- as.numeric(sort(x0))
+    lx0 <- length(x0)
+    B <- bootpars$B
+    hbound <- IQR(dfr$x)/1.349*bootpars$hbound
+    lhgrid <- bootpars$hl
+    steph <- (hbound[2]/hbound[1])^(1/lhgrid)
+    hgrid <- as.numeric(hbound[1]*steph^seq(0, lhgrid, length.out = lhgrid))
+    nrow <- dim(dfr)[1]
+    fpilot <- bootpars$fpilot
+    if (is.null(fpilot)) {
+        pilot <- npcure::hpilot(dfr$x, x0, bootpars$nnfrac)
+    }
+    else
+        pilot <- do.call(fpilot, c(list(x0 = x0), bootpars$dots))
+    probcurepilot <- as.numeric(probcure(x, t, d, dfr, x0, pilot)$q)
+    h <- .Call("probcurenp0hboot",
+               dfr$t,
+               dfr$x,
+               dfr$d,
+               nrow,
+               x0,
+               lx0,
+               hgrid,
+               lhgrid,
+               pilot,
+               probcurepilot,
+               B,
+               PACKAGE = "npcure")
+    result  <- list(type = c("Bootstrap bandwidth", "cure"), x0 = x0, h = h)
+    sm <- bootpars$hsmooth
+    if (sm > 1) {
+        if (sm >= lx0)
+            warning("The number of covariate values is probably too small for smoothing the selected bandwidths with hsmooth=", sm)
+        result$hsmooth <- zoo::rollapply(h, sm, mean, partial = TRUE, align = "center")
+    }
+    if (bootpars$hsave)
+        result$hgrid <- hgrid
+    structure(result, class = "npcure")
+}
+
+## Bootstrap bandwidth selector for the estimator of latency
+latencyhboot <- function(x,
+                         t,
+                         d,
+                         dataset,
+                         x0,
+                         bootpars = npcure::controlpars()) {
+    dfr <-
+        if (missing(dataset))
+            na.omit(data.frame(x, t, d))
+        else
+            na.omit(dataset[, c(deparse(substitute(x)), deparse(substitute(t)), deparse(substitute(d)))])
+    names(dfr) <- c("x", "t", "d")
+    dfr$x <- as.numeric(dfr$x)
+    dfr$t <- as.numeric(dfr$t)
+    dfr$d <- as.integer(dfr$d)
+    dfr <- dfr[order(dfr$t, 1 - dfr$d),]
+    x0 <- as.numeric(sort(x0))
+    lx0 <- length(x0)
+    B <- bootpars$B
+    boundh <- IQR(dfr$x)/1.349*bootpars$hbound
+    lhgrid <- bootpars$hl
+    tmax <- quantile(dfr$t, bootpars$qt)
+    steph <- (boundh[2]/boundh[1])^(1/lhgrid)
+    hgrid <- as.numeric(boundh[1]*steph^seq(0, lhgrid, length.out = lhgrid))
+    nrow <- dim(dfr)[1]
+    fpilot <- bootpars$fpilot
+    if (is.null(fpilot)) {
+        pilot <- npcure::hpilot(dfr$x, dfr$x, bootpars$nnfrac)
+        pilotx0 <- npcure::hpilot(dfr$x, x0, bootpars$nnfrac)
+    }
+    else {
+        pilot <- do.call(fpilot, c(list(x0 = dfr$x), bootpars$dots))
+        pilotx0 <- do.call(fpilot, c(list(x0 = x0), bootpars$dots))
+    }
+    probcurepilot <- as.numeric(probcure(x, t, d, dfr, dfr$x, pilot)$q)
+    latencypilot <- latency(x, t, d, dfr, x0, pilotx0)$S
+    h <- .Call("latencynp0hboot",
+               dfr$t,
+               dfr$x,
+               dfr$d,
+               nrow,
+               x0,
+               lx0,
+               hgrid,
+               lhgrid,
+               pilot,
+               probcurepilot,
+               latencypilot,
+               B,
+               tmax,
+               PACKAGE = "npcure")
+    result  <- list(type = c("Bootstrap bandwidth", "latency"), x0 = x0, h = h)
+    sm <- bootpars$hsmooth
+    if (sm > 1) {
+        if (sm >= lx0)
+            warning("The number of covariate values is probably too small for smoothing the selected bandwidths with hsmooth=", sm)
+        result$hsmooth <- zoo::rollapply(h, sm, mean, partial = TRUE, align = "center")
+    }
+    if (bootpars$hsave)
+        result$hgrid <- hgrid
+    structure(result, class = "npcure")
+}
+
+## Cross-validation bandwidth selector for Beran's survival estimator
+berancv <- function(x,
+                    t,
+                    d,
+                    dataset,
+                    x0,
+                    cvpars = npcure::controlpars()) {
+    dfr <-
+        if (missing(dataset))
+            na.omit(data.frame(x, t, d))
+        else 
+            na.omit(dataset[, c(deparse(substitute(x)), deparse(substitute(t)), deparse(substitute(d)))])
+    names(dfr) <- c("x", "t", "d")
+    dfr$x <- as.numeric(dfr$x)
+    dfr$t <- as.numeric(dfr$t)
+    dfr$d <- as.integer(dfr$d)
+    dfr <- dfr[order(dfr$t, 1 - dfr$d),]
+    x0 <- as.numeric(sort(x0))
+    lx0 <- length(x0)
+    nrow <- dim(dfr)[1]
+    boundh <- IQR(dfr$x)/1.349*cvpars$hbound
+    lhgrid <- cvpars$hl
+    steph <- (boundh[2]/boundh[1])^(1/lhgrid)
+    hgrid <- as.numeric(boundh[1]*steph^seq(0, lhgrid, length.out = lhgrid))
+    h <- .Call("berannp0cv",
+               dfr$t,
+               dfr$x,
+               dfr$d,
+               nrow,
+               x0,
+               lx0,
+               hgrid,
+               lhgrid,
+               PACKAGE = "npcure")
+    result  <- list(type = c("Cross-validation bandwidth", "survival"), x0 = x0, h = h)
+    sm <- cvpars$hsmooth
+    if (sm > 1) {
+        if (sm >= lx0)
+            warning("The number of covariate values is probably too small for smoothing the selected bandwidths with hsmooth=", sm)
+        result$hsmooth <- zoo::rollapply(h, sm, mean, partial = TRUE, align = "center")
+    }
+    if (cvpars$hsave)
+        result$hgrid <- hgrid
+    structure(result, class = "npcure")
+}