sahirbhatnagar / casebase
1
#' Population Time Plot Data
2
#'
3
#' Create a data frame for population time plots to give a visual representation
4
#' of incidence density
5
#'
6
#' @param data a \code{data.frame} or \code{data.table} containing the source
7
#'   dataset.
8
#' @param time a character string giving the name of the time variable. See
9
#'   Details.
10
#' @param event a character string giving the name of the event variable
11
#'   contained in \code{data}. See Details. If \code{event} is a numeric
12
#'   variable, then 0 needs to represent a censored observation, 1 needs to be
13
#'   the event of interest. Integers 2, 3, ... and so on are treated as
14
#'   competing events. If event is a \code{factor} or \code{character} and
15
#'   \code{censored.indicator} is not specified, this function will assume the
16
#'   reference level is the censored indicator
17
#' @param censored.indicator a character string of length 1 indicating which
18
#'   value in \code{event} is the censored. This function will use
19
#'   \code{\link[stats]{relevel}} to set \code{censored.indicator} as the
20
#'   reference level. This argument is ignored if the \code{event} variable is a
21
#'   numeric
22
#' @param exposure a character string of length 1 giving the name of the
23
#'   exposure variable which must be contained in \code{data}. Default is
24
#'   \code{NULL}. This is used to produced exposure stratified plots. If an
25
#'   \code{exposure} is specified, \code{popTime} returns an `exposure`
26
#'   attribute which contains the name of the exposure variable in the dataset.
27
#'   The plot method for objects of class `popTime` will use this exposure
28
#'   attribute to create exposure stratified population time plots.
29
#' @param percentile_number Default=0.5. Give a value between 0-1. if the
30
#'   percentile number of available subjects at any given point is less than 10,
31
#'   then sample regardless of case status. Depending on distribution of
32
#'   survival times and events event points may not be evenly distributed with
33
#'   default value.
34
#'
35
#'
36
#' @details It is assumed that \code{data} contains the two columns
37
#'   corresponding to the supplied time and event variables. If either the
38
#'   \code{time} or \code{event} argument is missing, the function looks for
39
#'   columns that contain the words \code{"time"}, \code{"event"}, or
40
#'   \code{"status"} in them (case insensitive). The function first looks for
41
#'   the time variable, then it looks for the event variable. This order of
42
#'   operation is important if for example the time variable is named
43
#'   \code{"event time"} and the event variable is named \code{"event
44
#'   indicator"}. This function will first (automatically) find the time
45
#'   variable and remove this as a possibility from subsequent searches of the
46
#'   event variable. The following regular expressions are used for the time and
47
#'   event variables: \describe{ \item{time}{\code{"[\\s\\W_]+time|^time\\b"}}
48
#'   \item{event}{\code{"[\\s\\W_]+event|^event\\b|[\\s\\W_]+status|^status\\b"}}
49
#'    } This allows for \code{"time"} to be preceded or followed by one or more
50
#'   white space characters, one or more non-word characters or one or more
51
#'   underscores. For example, the following column names would be recognized by
52
#'   the function as the \code{"time"} variable: \code{"time of death",
53
#'   "death_time", "Time", "time", "diagnosis_time", "time.diag", "diag__time"}.
54
#'   But the following will not be recognized: \code{"diagtime","eventtime",
55
#'   "Timediag"}
56
#' @return An object of class \code{popTime} (or \code{popTimeExposure} if
57
#'   exposure is specified), \code{data.table} and \code{data.frame} in this
58
#'   order! The output of this function is to be used with the plot method for
59
#'   objects of class \code{popTime} or of class \code{popTimeExposure}, which
60
#'   will produce population time plots. This dataset augments the original data
61
#'   with the following columns: \describe{\item{original.time}{value of the
62
#'   time variable in the original dataset - the one specified by the
63
#'   \code{time} user argument to this function}\item{original.event}{value of
64
#'   the event variable in the original dataset - the one specified by the
65
#'   \code{event} user argument to this function}\item{time}{renames the user
66
#'   specified time column to time}\item{event}{renames the user specified event
67
#'   argument to event}}
68
#' @seealso \code{\link{plot.popTime}}
69
#' @examples
70
#' data("bmtcrr")
71
#' popTimeData <- popTime(data = bmtcrr, time = "ftime")
72
#' class(popTimeData)
73
#' popTimeData <- popTime(data = bmtcrr, time = "ftime", exposure = "D")
74
#' attr(popTimeData, "exposure")
75
#' @export
76
#' @importFrom data.table as.data.table rbindlist := setnames .N
77
#' @importFrom stats quantile
78
popTime <- function(data, time, event, censored.indicator,
79
                    exposure, percentile_number) {
80

81 2
  varNames <- checkArgsTimeEvent(data = data, time = time, event = event)
82 2
  ycoord <- yc <- n_available <- NULL
83

84 2
  DT <- data.table::as.data.table(data)
85 2
  if (missing(percentile_number)) {
86 2
    percentile_number <- 0.5
87
  }
88 2
  if (missing(censored.indicator)) {
89 2
    censored.indicator <- NULL
90
  }
91 2
  if (missing(exposure)) {
92 2
    nobs <- nrow(DT)
93

94 2
    DT[, "original.time" := get(varNames$time)]
95 2
    DT[, "original.event" := get(varNames$event)]
96

97 0
    if (varNames$time != "time") setnames(DT, varNames$time, "time")
98 2
    if (varNames$event != "event") setnames(DT, varNames$event, "event")
99 2
    modifiedEvent <- checkArgsEventIndicator(
100 2
      data = data, event = varNames$event,
101 2
      censored.indicator = censored.indicator
102
    )
103

104 2
    DT[, event := modifiedEvent$event.numeric]
105 2
    DT[, "event status" := modifiedEvent$event.factored]
106

107
    # people with
108
    # short values of t at the top
109 2
    DT[DT[, order(time)], ycoord := (nobs:1)]
110

111
    # sample y coordinates for each event, so that we can see the incidence
112
    # density on population-time plots. Sampling from people who have an
113
    # observed time t greater than that of a fixed individual who had the event
114

115
    # need to
116
    # if there are only two levels, then find out how many controls
117
    # are left to sample from. if there are three levels,
118
    # check to see if there are enough 0's and 2's to sample from (this
119
    # implicitly assumes event=1 is the event of interest)
120
    # we only plot events==1 (i.e. the event of interest)
121 2
    DT[, yc := 0L]
122 2
    DT[, n_available := 0L]
123

124 2
    DT[event == 1, n_available := sapply(
125 2
      time,
126 2
      function(i) DT[time >= i & event != 1, .N]
127
    )]
128

129
    # if the 50th percentile number of available subjects at any given
130
    # point is less than 10, then sample regardless of case status
131
    ### NEED TO MAKE THIS LESS STRINGENT##############??????
132 2
    if (DT[, stats::quantile(n_available, probs = percentile_number)] < 15) {
133 2
      DT[
134 2
        event == 1,
135 2
        n_available := sapply(
136 2
          time,
137 2
          function(i) DT[time >= i, .N]
138
        )
139
      ]
140

141 2
      DT[
142 2
        event == 1 & n_available > 0,
143 2
        yc := sapply(
144 2
          time,
145 2
          function(i) {
146 2
            sample(DT[time >= i, ycoord], 1)
147
          }
148
        )
149
      ]
150

151
      # use original coordinate if there is no one left to sample from
152 2
      DT[event == 1 & n_available == 0, yc := ycoord]
153
    } else {
154 0
      DT[
155 0
        event == 1 & n_available > 0,
156 0
        yc := sapply(
157 0
          time,
158 0
          function(i) {
159 0
            sample(DT[time >= i & event != 1, ycoord], 1)
160
          }
161
        )
162
      ]
163

164
      # use original coordinate if there is no one left to sample from
165 0
      DT[event == 1 & n_available == 0, yc := ycoord]
166
    }
167 2
    class(DT) <- c("popTime", class(DT))
168 2
    attr(DT, "exposure") <- NULL
169 2
    attr(DT, "call") <- match.call()
170 2
    return(DT)
171
  } else {
172 2
    DT[, "original.time" := get(varNames$time)]
173 2
    DT[, "original.event" := get(varNames$event)]
174

175 0
    if (varNames$time != "time") setnames(DT, varNames$time, "time")
176 2
    if (varNames$event != "event") setnames(DT, varNames$event, "event")
177

178 2
    l <- split(DT, DT[[exposure]])
179 2
    l <- lapply(
180 2
      l,
181 2
      function(i) {
182 2
        transform(i,
183 2
          event = checkArgsEventIndicator(
184 2
            data = i, event = "event",
185 2
            censored.indicator = censored.indicator
186 2
          )$event.numeric,
187 2
          `event status` = checkArgsEventIndicator(
188 2
            data = i, event = "event",
189 2
            censored.indicator = censored.indicator
190 2
          )$event.factor
191
        )
192
      }
193
    )
194

195 2
    lapply(l, function(i) {
196 2
      nobs <- nrow(i)
197 2
      i[i[, order(time)], ycoord := (nobs:1)]
198
    })
199

200
    # sample y coordinates for each event, so that we can see the incidence
201
    # density on population-time plots. Sampling from people who have an
202
    # observed time t greater than that of a fixed individual who had the event
203
    # if there are only two levels, then find out how many controls
204
    # are left to sample from. if there are three levels,
205
    # check to see if there are enough 0's and 2's to sample from (this
206
    # implicitly assumes event=1 is the event of interest)
207
    # we only plot events==1 (i.e. the event of interest)
208

209 2
    lapply(l, function(K) {
210 2
      K[, yc := 0L]
211 2
      K[, n_available := 0L]
212

213 2
      K[event == 1, n_available := sapply(
214 2
        time,
215 2
        function(i) K[time >= i & event != 1, .N]
216
      )]
217

218
      # if the 50th percentile number of available subjects at any given
219
      # point is less than 10, then sample regardless of case status
220 2
      if (K[, quantile(n_available, probs = percentile_number)] < 10) {
221 2
        K[
222 2
          event == 1,
223 2
          n_available := sapply(
224 2
            time,
225 2
            function(i) K[time >= i, .N]
226
          )
227
        ]
228

229 2
        K[
230 2
          event == 1 & n_available > 0,
231 2
          yc := sapply(
232 2
            time,
233 2
            function(i) {
234 2
              sample(K[time >= i, ycoord], 1)
235
            }
236
          )
237
        ]
238

239
        # use original coordinate if there is no one left to sample from
240 2
        K[event == 1 & n_available == 0, yc := ycoord]
241
      } else {
242 0
        K[
243 0
          event == 1 & n_available > 0,
244 0
          yc := sapply(
245 0
            time,
246 0
            function(i) {
247 0
              sample(K[time >= i & event != 1, ycoord], 1)
248
            }
249
          )
250
        ]
251

252
        # use original coordinate if there is no one left to sample from
253 0
        K[event == 1 & n_available == 0, yc := ycoord]
254
      }
255
    })
256

257 2
    lk <- data.table::rbindlist(l)
258 2
    attr(lk, "exposure") <- exposure
259 2
    class(lk) <- c("popTime", class(lk))
260 2
    attr(lk, "call") <- match.call()
261 2
    return(lk)
262
  }
263
}
264

265
# taken verbatim from cowplot::theme_cowplot()
266
#' @importFrom stats quantile
267
#' @importFrom grid unit
268
#' @importFrom ggplot2 theme_grey theme element_line element_rect element_text
269
#' @importFrom ggplot2 margin element_blank rel %+replace%
270
theme_cb <- function(font_size = 14, font_family = "", line_size = 0.5,
271
                     rel_small = 12/14, rel_tiny = 11/14, rel_large = 16/14) {
272 2
  half_line <- 0.5 * font_size
273 2
  small_size <- rel_small * font_size
274 2
  ggplot2::theme_grey(base_size = font_size, base_family = font_family) %+replace%
275 2
    theme(line = element_line(color = "black", size = line_size,
276 2
                              linetype = 1, lineend = "butt"), rect = element_rect(fill = NA,
277 2
                                                                                   color = NA, size = line_size, linetype = 1), text = element_text(family = font_family,
278 2
                                                                                                                                                    face = "plain", color = "black", size = font_size,
279 2
                                                                                                                                                    hjust = 0.5, vjust = 0.5, angle = 0, lineheight = 0.9,
280 2
                                                                                                                                                    margin = margin(), debug = FALSE), axis.line = element_line(color = "black",
281 2
                                                                                                                                                                                                                size = line_size, lineend = "square"), axis.line.x = NULL,
282 2
          axis.line.y = NULL, axis.text = element_text(color = "black",
283 2
                                                       size = small_size), axis.text.x = element_text(margin = margin(t = 0.25 * small_size),
284 2
                                                                                                      vjust = 1), axis.text.x.top = element_text(margin = margin(b = 0.25 * small_size),
285 2
                                                                                                                                                 vjust = 0), axis.text.y = element_text(margin = margin(r = 0.25 * small_size),
286 2
                                                                                                                                                                                        hjust = 1), axis.text.y.right = element_text(margin = margin(l = 0.25 * small_size),
287 2
                                                                                                                                                                                                                                     hjust = 0), axis.ticks = element_line(color = "black",
288 2
                                                                                                                                                                                                                                                                           size = line_size), axis.ticks.length = unit(0.5 * half_line,
289 2
                                                                                                                                                                                                                                                                                                                       "pt"), axis.title.x = element_text(margin = margin(t = 0.5 * half_line),
290 2
                                                                                                                                                                                                                                                                                                                                                          vjust = 1), axis.title.x.top = element_text(margin = margin(b = 0.5 * half_line),
291 2
                                                                                                                                                                                                                                                                                                                                                                                                      vjust = 0), axis.title.y = element_text(angle = 90,
292 2
                                                                                                                                                                                                                                                                                                                                                                                                                                              margin = margin(r = 0.5 * half_line),
293 2
                                                                                                                                                                                                                                                                                                                                                                                                                                              vjust = 1),
294 2
          axis.title.y.right = element_text(angle = -90, margin = margin(l = 0.5 * half_line),
295 2
                                            vjust = 0), legend.background = element_blank(),
296 2
          legend.spacing = unit(font_size, "pt"), legend.spacing.x = NULL,
297 2
          legend.spacing.y = NULL, legend.margin = margin(0,
298 2
                                                          0, 0, 0), legend.key = element_blank(), legend.key.size = unit(1.1 *
299 2
                                                                                                                           font_size, "pt"), legend.key.height = NULL,
300 2
          legend.key.width = NULL, legend.text = element_text(size = rel(rel_small)),
301 2
          legend.text.align = NULL, legend.title = element_text(hjust = 0),
302 2
          legend.title.align = NULL, legend.position = "right",
303 2
          legend.direction = NULL, legend.justification = c("left",
304 2
                                                            "center"), legend.box = NULL, legend.box.margin = margin(0,
305 2
                                                                                                                     0, 0, 0), legend.box.background = element_blank(),
306 2
          legend.box.spacing = unit(font_size, "pt"), panel.background = element_blank(),
307 2
          panel.border = element_blank(), panel.grid = element_blank(),
308 2
          panel.grid.major = NULL, panel.grid.minor = NULL,
309 2
          panel.grid.major.x = NULL, panel.grid.major.y = NULL,
310 2
          panel.grid.minor.x = NULL, panel.grid.minor.y = NULL,
311 2
          panel.spacing = unit(half_line, "pt"), panel.spacing.x = NULL,
312 2
          panel.spacing.y = NULL, panel.ontop = FALSE, strip.background = element_rect(fill = "grey80"),
313 2
          strip.text = element_text(size = rel(rel_small),
314 2
                                    margin = margin(0.5 * half_line, 0.5 * half_line, 0.5 * half_line,
315 2
                                                    0.5 * half_line)), strip.text.x = NULL, strip.text.y = element_text(angle = -90),
316 2
          strip.placement = "inside", strip.placement.x = NULL,
317 2
          strip.placement.y = NULL, strip.switch.pad.grid = unit(0.5 * half_line,
318 2
                                                                 "pt"), strip.switch.pad.wrap = unit(0.5 * half_line,
319 2
                                                                                                     "pt"), plot.background = element_blank(), plot.title = element_text(face = "bold",
320 2
                                                                                                                                                                         size = rel(rel_large), hjust = 0, vjust = 1,
321 2
                                                                                                                                                                         margin = margin(b = half_line)), plot.subtitle = element_text(size = rel(rel_small),
322 2
                                                                                                                                                                                                                                       hjust = 0, vjust = 1, margin = margin(b = half_line)),
323 2
          plot.caption = element_text(size = rel(rel_tiny),
324 2
                                      hjust = 1, vjust = 1, margin = margin(t = half_line)),
325 2
          plot.tag = element_text(face = "bold", hjust = 0,
326 2
                                  vjust = 0.7), plot.tag.position = c(0, 1), plot.margin = margin(half_line,
327 2
                                                                                                  half_line, half_line, half_line), complete = TRUE)
328
}
329

330

331

332
# taken verbatim from cowplot::panel_border
333
#' @importFrom ggplot2 theme element_blank element_rect
334
panelBorder <- function(color = "grey85", size = 1, linetype = 1,
335
                        remove = FALSE, colour) {
336 0
  if (!missing(colour)) {
337 0
    color <- colour
338
  }
339 0
  if (remove) {
340 0
    return(theme(panel.border = element_blank()))
341
  }
342 0
  theme(panel.border = element_rect(
343 0
    color = color, fill = NA,
344 0
    linetype = linetype, size = size
345
  ))
346
}

Read our documentation on viewing source code .

Loading