ggplot2.utils coverage - 100.00%

Files
Source

#' Helper for Common Kaplan-Meier Computations
#'
#' @param data (`data.frame`)\cr with `time` and `status` numeric columns.
#' @returns The [survival::survfit()] result as basis of
#'   the Kaplan-Meier estimate.
#'
#' @keywords internal
h_surv_fit <- function(data) {
  assert_data_frame(data)
  assert_subset(c("time", "status"), names(data))
  assert_numeric(data$status)
  assert_numeric(data$time)

  surv_fit <- survival::survfit(
    survival::Surv(data$time, data$status) ~ 1,
    se.fit = FALSE,
    stype = 1,
    ctype = 1
  )
  assert_numeric(surv_fit$surv)
  surv_fit
}

#' Helper for `stat_km`
#'
#' @inheritParams h_surv_fit
#' @param scales not used.
#' @returns A `data.frame` with `time` and `survival` columns.
#'
#' @keywords internal
stat_km_compute <- function(data, scales) {
  surv_fit <- h_surv_fit(data)
  first <- c(0, 1)
  data.frame(
    time = c(first[1], surv_fit$time),
    survival = c(first[2], surv_fit$surv)
  )
}

#' Helper for `stat_km_ticks`
#'
#' @inheritParams stat_km_compute
#' @returns A `data.frame` with `time`, `survival`, `n.risk`, `n.censor` and `n.event`
#'   columns.
#'
#' @keywords internal
stat_km_ticks_compute <- function(data, scales) {
  surv_fit <- h_surv_fit(data)
  data.frame(
    time = surv_fit$time,
    survival = surv_fit$surv,
    n.risk = surv_fit$n.risk,
    n.censor = surv_fit$n.censor,
    n.event = surv_fit$n.event
  )
}

#' Add a Kaplan-Meier Survival Curve
#'
#' @description `r lifecycle::badge("experimental")`
#' Adds the Kaplan-Meier survival curve.
#'
#' @inheritParams ggplot2::geom_step
#'
#' @section Aesthetics:
#' `geom_km()` understands the following aesthetics (required aesthetics in bold):
#'
#' - **`x`**: the survival/censoring times, automatically mapped by [stat_km()].
#' - **`y`**: the survival probability estimates, automatically mapped by [stat_km()].
#' - `alpha`
#' - `color`
#' - `linetype`
#' - `linewidth`
#'
#' @seealso The default `stat` for this `geom` is [stat_km()].
#'
#' @author Inspired by `geom_km` written by Michael Sachs (in `ggkm`) and
#'   Samer Mouksassi (in `ggquickeda`). Here we directly use [ggplot2::geom_step()]
#'   instead of the more general [ggplot2::geom_path()].
#' @export
#' @examples
#' library(ggplot2)
#' sex <- rbinom(250, 1, .5)
#' df <- data.frame(
#'   time = exp(rnorm(250, mean = sex)),
#'   status = rbinom(250, 1, .75),
#'   sex = sex
#' )
#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
#'   geom_km()
geom_km <- function(mapping = NULL,
                    data = NULL,
                    stat = "km",
                    position = "identity",
                    show.legend = NA,
                    inherit.aes = TRUE,
                    na.rm = TRUE,
                    ...) {
  ggplot2::layer(
    geom = GeomKm,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

# GeomKm ----

#' @rdname ggproto
#' @export
GeomKm <- ggplot2::ggproto(
  "GeomKm",
  ggplot2::GeomStep,
  draw_group = function(data, scales, coordinates, ...) {
    path <- transform(data, alpha = NA)
    ggplot2::GeomStep$draw_panel(path, scales, coordinates, direction = "hv")
  },
  required_aes = c("x", "y"),
  default_aes = ggplot2::aes(
    colour = "black",
    fill = "grey60",
    linewidth = 0.75,
    linetype = 1,
    weight = 1,
    alpha = 1
  )
)

#' @include stat_km_compute.R
NULL

#' Adds a Kaplan-Meier Estimate of Survival Statistic
#'
#' @description `r lifecycle::badge("experimental")`
#' This `stat` is for computing the Kaplan-Meier survival estimate for
#' right-censored data. It requires the aesthetic mapping `time` for the
#' observation times and `status` which indicates the event status,
#' either 0 for alive and 1 for dead, or 1 for alive and 2 for dead.
#'
#' @note Logical `status` is not supported.
#'
#' @inheritParams ggplot2::stat_identity
#'
#' @returns A `data.frame` with columns:
#'   - `time`: `time` in `data`.
#'   - `survival`: survival estimate at `time`.
#'
#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
#' @export
#' @examples
#' library(ggplot2)
#' sex <- rbinom(250, 1, .5)
#' df <- data.frame(
#'   time = exp(rnorm(250, mean = sex)),
#'   status = rbinom(250, 1, .75),
#'   sex = sex
#' )
#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
#'   stat_km()
stat_km <- function(mapping = NULL,
                    data = NULL,
                    geom = "km",
                    position = "identity",
                    show.legend = NA,
                    inherit.aes = TRUE,
                    ...) {
  ggplot2::layer(
    stat = StatKm,
    data = data,
    mapping = mapping,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(...)
  )
}

#' @rdname ggproto
#' @export
StatKm <- ggplot2::ggproto(
  "StatKm",
  ggplot2::Stat,
  compute_group = stat_km_compute,
  default_aes = ggplot2::aes(y = ..survival.., x = ..time..),
  required_aes = c("time", "status"),
  dropped_aes = "status"
)

#' @include stat_km_compute.R
NULL

#' Adds Tick Marks to a Kaplan-Meier Estimate of Survival Statistic
#'
#' @description `r lifecycle::badge("experimental")`
#' This `stat` is for computing the location of the tick marks for the
#' Kaplan-Meier survival estimate for right-censored data.
#' It requires the aesthetic mapping `time` for the
#' observation times and `status` which indicates the event status,
#' either 0 for alive and 1 for dead, or 1 for alive and 2 for dead.
#'
#' @note Logical `status` is not supported.
#'
#' @inheritParams ggplot2::stat_identity
#' @inheritParams stat_km
#'
#' @returns A `data.frame` with columns:
#'   - `time`: `time` in `data`.
#'   - `survival`: survival estimate at `time`.
#'   - `n.risk`: number of patients at risk.
#'   - `n.censor`: number of patients censored.
#'   - `n.event`: number of patients with event.
#'
#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
#' @export
#' @examples
#' library(ggplot2)
#' sex <- rbinom(250, 1, .5)
#' df <- data.frame(
#'   time = exp(rnorm(250, mean = sex)),
#'   status = rbinom(250, 1, .75),
#'   sex = sex
#' )
#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
#'   stat_km() +
#'   stat_km_ticks()
stat_km_ticks <- function(mapping = NULL,
                          data = NULL,
                          geom = "km_ticks",
                          position = "identity",
                          show.legend = NA,
                          inherit.aes = TRUE,
                          ...) {
  ggplot2::layer(
    stat = StatKmTicks,
    data = data,
    mapping = mapping,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(...)
  )
}

#' @rdname ggproto
#' @export
StatKmTicks <- ggplot2::ggproto(
  "StatKmTicks",
  ggplot2::Stat,
  compute_group = stat_km_ticks_compute,
  default_aes = ggplot2::aes(y = ..survival.., x = ..time..),
  required_aes = c("time", "status"),
  dropped_aes = "status"
)

#' Add Tick Marks to a Kaplan-Meier Survival Curve
#'
#' @description `r lifecycle::badge("experimental")`
#' Adds tickmarks at the times when there are censored observations but no
#' events.
#'
#' @inheritParams ggplot2::geom_point
#'
#' @section Aesthetics:
#' `geom_km_ticks()` understands the following aesthetics (required aesthetics in bold):
#'
#' - **`x`**: the survival/censoring times, automatically mapped by [stat_km_ticks()].
#' - **`y`**: the survival probability estimates, automatically mapped by [stat_km_ticks()].
#' - `alpha`
#' - `color`
#' - `shape`
#' - `size`
#' - `stroke`
#' - `fill`
#'
#' @seealso The default `stat` for this `geom` is [stat_km_ticks()].
#'
#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
#' @export
#' @examples
#' library(ggplot2)
#' sex <- rbinom(250, 1, .5)
#' df <- data.frame(
#'   time = exp(rnorm(250, mean = sex)),
#'   status = rbinom(250, 1, .75),
#'   sex = sex
#' )
#' ggplot(df, aes(time = time, status = status, color = factor(sex), group = factor(sex))) +
#'   geom_km() +
#'   geom_km_ticks(col = "black")
geom_km_ticks <- function(mapping = NULL,
                          data = NULL,
                          stat = "km_ticks",
                          position = "identity",
                          show.legend = NA,
                          inherit.aes = TRUE,
                          na.rm = TRUE,
                          ...) {
  ggplot2::layer(
    geom = GeomKmTicks,
    mapping = mapping,
    data = data,
    stat = stat,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

# GeomKmTicks ----

#' @rdname ggproto
#' @export
GeomKmTicks <- ggplot2::ggproto(
  "GeomKmTicks",
  ggplot2::Geom,
  draw_group = function(data, scales, coordinates, ...) {
    showpoints <- data$n.censor > 0 & data$n.event == 0
    coordsp <- coordinates$transform(data, scales)[showpoints, , drop = FALSE]
    if (nrow(coordsp) == 0) {
      grid::nullGrob()
    } else {
      grid::pointsGrob(
        coordsp$x,
        coordsp$y,
        pch = coordsp$shape,
        size = grid::unit(coordsp$size, "char"),
        gp = grid::gpar(
          col = coordsp$colour,
          fill = coordsp$fill,
          alpha = coordsp$alpha
        )
      )
    }
  },
  required_aes = c("x", "y"),
  non_missing_aes = c("size", "shape"),
  default_aes = ggplot2::aes(
    shape = 3,
    colour = "black",
    size = .75,
    alpha = 1,
    stroke = 0.5,
    fill = "black"
  ),
  draw_key = ggplot2::draw_key_point
)

1		#' Helper for Common Kaplan-Meier Computations
2		#'
3		#' @param data (`data.frame`)\cr with `time` and `status` numeric columns.
4		#' @returns The [survival::survfit()] result as basis of
5		#' the Kaplan-Meier estimate.
6		#'
7		#' @keywords internal
8		h_surv_fit <- function(data) {
9	14x	assert_data_frame(data)
10	14x	assert_subset(c("time", "status"), names(data))
11	14x	assert_numeric(data$status)
12	14x	assert_numeric(data$time)
13
14	14x	surv_fit <- survival::survfit(
15	14x	survival::Surv(data$time, data$status) ~ 1,
16	14x	se.fit = FALSE,
17	14x	stype = 1,
18	14x	ctype = 1
19		)
20	14x	assert_numeric(surv_fit$surv)
21	14x	surv_fit
22		}
23
24		#' Helper for `stat_km`
25		#'
26		#' @inheritParams h_surv_fit
27		#' @param scales not used.
28		#' @returns A `data.frame` with `time` and `survival` columns.
29		#'
30		#' @keywords internal
31		stat_km_compute <- function(data, scales) {
32	1x	surv_fit <- h_surv_fit(data)
33	1x	first <- c(0, 1)
34	1x	data.frame(
35	1x	time = c(first[1], surv_fit$time),
36	1x	survival = c(first[2], surv_fit$surv)
37		)
38		}
39
40		#' Helper for `stat_km_ticks`
41		#'
42		#' @inheritParams stat_km_compute
43		#' @returns A `data.frame` with `time`, `survival`, `n.risk`, `n.censor` and `n.event`
44		#' columns.
45		#'
46		#' @keywords internal
47		stat_km_ticks_compute <- function(data, scales) {
48	1x	surv_fit <- h_surv_fit(data)
49	1x	data.frame(
50	1x	time = surv_fit$time,
51	1x	survival = surv_fit$surv,
52	1x	n.risk = surv_fit$n.risk,
53	1x	n.censor = surv_fit$n.censor,
54	1x	n.event = surv_fit$n.event
55		)
56		}

1		#' Add a Kaplan-Meier Survival Curve
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' Adds the Kaplan-Meier survival curve.
5		#'
6		#' @inheritParams ggplot2::geom_step
7		#'
8		#' @section Aesthetics:
9		#' `geom_km()` understands the following aesthetics (required aesthetics in bold):
10		#'
11		#' - `x`: the survival/censoring times, automatically mapped by [stat_km()].
12		#' - `y`: the survival probability estimates, automatically mapped by [stat_km()].
13		#' - `alpha`
14		#' - `color`
15		#' - `linetype`
16		#' - `linewidth`
17		#'
18		#' @seealso The default `stat` for this `geom` is [stat_km()].
19		#'
20		#' @author Inspired by `geom_km` written by Michael Sachs (in `ggkm`) and
21		#' Samer Mouksassi (in `ggquickeda`). Here we directly use [ggplot2::geom_step()]
22		#' instead of the more general [ggplot2::geom_path()].
23		#' @export
24		#' @examples
25		#' library(ggplot2)
26		#' sex <- rbinom(250, 1, .5)
27		#' df <- data.frame(
28		#' time = exp(rnorm(250, mean = sex)),
29		#' status = rbinom(250, 1, .75),
30		#' sex = sex
31		#' )
32		#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
33		#' geom_km()
34		geom_km <- function(mapping = NULL,
35		data = NULL,
36		stat = "km",
37		position = "identity",
38		show.legend = NA,
39		inherit.aes = TRUE,
40		na.rm = TRUE,
41		...) {
42	3x	ggplot2::layer(
43	3x	geom = GeomKm,
44	3x	mapping = mapping,
45	3x	data = data,
46	3x	stat = stat,
47	3x	position = position,
48	3x	show.legend = show.legend,
49	3x	inherit.aes = inherit.aes,
50	3x	params = list(na.rm = na.rm, ...)
51		)
52		}
53
54		# GeomKm ----
55
56		#' @rdname ggproto
57		#' @export
58		GeomKm <- ggplot2::ggproto(
59		"GeomKm",
60		ggplot2::GeomStep,
61		draw_group = function(data, scales, coordinates, ...) {
62		path <- transform(data, alpha = NA)
63		ggplot2::GeomStep$draw_panel(path, scales, coordinates, direction = "hv")
64		},
65		required_aes = c("x", "y"),
66		default_aes = ggplot2::aes(
67		colour = "black",
68		fill = "grey60",
69		linewidth = 0.75,
70		linetype = 1,
71		weight = 1,
72		alpha = 1
73		)
74		)

1		#' @include stat_km_compute.R
2		NULL
3
4		#' Adds a Kaplan-Meier Estimate of Survival Statistic
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#' This `stat` is for computing the Kaplan-Meier survival estimate for
8		#' right-censored data. It requires the aesthetic mapping `time` for the
9		#' observation times and `status` which indicates the event status,
10		#' either 0 for alive and 1 for dead, or 1 for alive and 2 for dead.
11		#'
12		#' @note Logical `status` is not supported.
13		#'
14		#' @inheritParams ggplot2::stat_identity
15		#'
16		#' @returns A `data.frame` with columns:
17		#' - `time`: `time` in `data`.
18		#' - `survival`: survival estimate at `time`.
19		#'
20		#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
21		#' @export
22		#' @examples
23		#' library(ggplot2)
24		#' sex <- rbinom(250, 1, .5)
25		#' df <- data.frame(
26		#' time = exp(rnorm(250, mean = sex)),
27		#' status = rbinom(250, 1, .75),
28		#' sex = sex
29		#' )
30		#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
31		#' stat_km()
32		stat_km <- function(mapping = NULL,
33		data = NULL,
34		geom = "km",
35		position = "identity",
36		show.legend = NA,
37		inherit.aes = TRUE,
38		...) {
39	1x	ggplot2::layer(
40	1x	stat = StatKm,
41	1x	data = data,
42	1x	mapping = mapping,
43	1x	geom = geom,
44	1x	position = position,
45	1x	show.legend = show.legend,
46	1x	inherit.aes = inherit.aes,
47	1x	params = list(...)
48		)
49		}
50
51		#' @rdname ggproto
52		#' @export
53		StatKm <- ggplot2::ggproto(
54		"StatKm",
55		ggplot2::Stat,
56		compute_group = stat_km_compute,
57		default_aes = ggplot2::aes(y = ..survival.., x = ..time..),
58		required_aes = c("time", "status"),
59		dropped_aes = "status"
60		)

1		#' @include stat_km_compute.R
2		NULL
3
4		#' Adds Tick Marks to a Kaplan-Meier Estimate of Survival Statistic
5		#'
6		#' @description `r lifecycle::badge("experimental")`
7		#' This `stat` is for computing the location of the tick marks for the
8		#' Kaplan-Meier survival estimate for right-censored data.
9		#' It requires the aesthetic mapping `time` for the
10		#' observation times and `status` which indicates the event status,
11		#' either 0 for alive and 1 for dead, or 1 for alive and 2 for dead.
12		#'
13		#' @note Logical `status` is not supported.
14		#'
15		#' @inheritParams ggplot2::stat_identity
16		#' @inheritParams stat_km
17		#'
18		#' @returns A `data.frame` with columns:
19		#' - `time`: `time` in `data`.
20		#' - `survival`: survival estimate at `time`.
21		#' - `n.risk`: number of patients at risk.
22		#' - `n.censor`: number of patients censored.
23		#' - `n.event`: number of patients with event.
24		#'
25		#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
26		#' @export
27		#' @examples
28		#' library(ggplot2)
29		#' sex <- rbinom(250, 1, .5)
30		#' df <- data.frame(
31		#' time = exp(rnorm(250, mean = sex)),
32		#' status = rbinom(250, 1, .75),
33		#' sex = sex
34		#' )
35		#' ggplot(df, aes(time = time, status = status, color = factor(sex))) +
36		#' stat_km() +
37		#' stat_km_ticks()
38		stat_km_ticks <- function(mapping = NULL,
39		data = NULL,
40		geom = "km_ticks",
41		position = "identity",
42		show.legend = NA,
43		inherit.aes = TRUE,
44		...) {
45	1x	ggplot2::layer(
46	1x	stat = StatKmTicks,
47	1x	data = data,
48	1x	mapping = mapping,
49	1x	geom = geom,
50	1x	position = position,
51	1x	show.legend = show.legend,
52	1x	inherit.aes = inherit.aes,
53	1x	params = list(...)
54		)
55		}
56
57		#' @rdname ggproto
58		#' @export
59		StatKmTicks <- ggplot2::ggproto(
60		"StatKmTicks",
61		ggplot2::Stat,
62		compute_group = stat_km_ticks_compute,
63		default_aes = ggplot2::aes(y = ..survival.., x = ..time..),
64		required_aes = c("time", "status"),
65		dropped_aes = "status"
66		)

1		#' Add Tick Marks to a Kaplan-Meier Survival Curve
2		#'
3		#' @description `r lifecycle::badge("experimental")`
4		#' Adds tickmarks at the times when there are censored observations but no
5		#' events.
6		#'
7		#' @inheritParams ggplot2::geom_point
8		#'
9		#' @section Aesthetics:
10		#' `geom_km_ticks()` understands the following aesthetics (required aesthetics in bold):
11		#'
12		#' - `x`: the survival/censoring times, automatically mapped by [stat_km_ticks()].
13		#' - `y`: the survival probability estimates, automatically mapped by [stat_km_ticks()].
14		#' - `alpha`
15		#' - `color`
16		#' - `shape`
17		#' - `size`
18		#' - `stroke`
19		#' - `fill`
20		#'
21		#' @seealso The default `stat` for this `geom` is [stat_km_ticks()].
22		#'
23		#' @author Michael Sachs (in `ggkm`), Samer Mouksassi (in `ggquickeda`).
24		#' @export
25		#' @examples
26		#' library(ggplot2)
27		#' sex <- rbinom(250, 1, .5)
28		#' df <- data.frame(
29		#' time = exp(rnorm(250, mean = sex)),
30		#' status = rbinom(250, 1, .75),
31		#' sex = sex
32		#' )
33		#' ggplot(df, aes(time = time, status = status, color = factor(sex), group = factor(sex))) +
34		#' geom_km() +
35		#' geom_km_ticks(col = "black")
36		geom_km_ticks <- function(mapping = NULL,
37		data = NULL,
38		stat = "km_ticks",
39		position = "identity",
40		show.legend = NA,
41		inherit.aes = TRUE,
42		na.rm = TRUE,
43		...) {
44	3x	ggplot2::layer(
45	3x	geom = GeomKmTicks,
46	3x	mapping = mapping,
47	3x	data = data,
48	3x	stat = stat,
49	3x	position = position,
50	3x	show.legend = show.legend,
51	3x	inherit.aes = inherit.aes,
52	3x	params = list(na.rm = na.rm, ...)
53		)
54		}
55
56		# GeomKmTicks ----
57
58		#' @rdname ggproto
59		#' @export
60		GeomKmTicks <- ggplot2::ggproto(
61		"GeomKmTicks",
62		ggplot2::Geom,
63		draw_group = function(data, scales, coordinates, ...) {
64		showpoints <- data$n.censor > 0 & data$n.event == 0
65		coordsp <- coordinates$transform(data, scales)[showpoints, , drop = FALSE]
66		if (nrow(coordsp) == 0) {
67		grid::nullGrob()
68		} else {
69		grid::pointsGrob(
70		coordsp$x,
71		coordsp$y,
72		pch = coordsp$shape,
73		size = grid::unit(coordsp$size, "char"),
74		gp = grid::gpar(
75		col = coordsp$colour,
76		fill = coordsp$fill,
77		alpha = coordsp$alpha
78		)
79		)
80		}
81		},
82		required_aes = c("x", "y"),
83		non_missing_aes = c("size", "shape"),
84		default_aes = ggplot2::aes(
85		shape = 3,
86		colour = "black",
87		size = .75,
88		alpha = 1,
89		stroke = 0.5,
90		fill = "black"
91		),
92		draw_key = ggplot2::draw_key_point
93		)