1
#' @import XML
2
#' @import data.table
3
#' @import yaml
4
#' @importFrom Rcpp evalCpp
5
NULL
6

7

8
#' The S4 class which holds all the CCHIC patient record - served as a database.
9
#'
10
#' @description  ccRecord is a class to hold the raw episode data parsed directly 
11
#' from XML or CSV files.
12
#' @field nepisodes is an integer number indicates the total number of episode
13
#'       the record is holding.
14
#' @field dmgtb a data.table containing all the demographic information of each
15
#'       episode, including site_id, NHS number, PAS number, admission date/time,
16
#'       and discharge date/time. This field is usually left empty.
17
#' @field infotb a data.table holding the parsing information of each episode such as the
18
#'       parsing time and from which file it parsed from.
19
#' @field episdoes a list of ccEpisode objects. 
20
#' @exportClass ccRecord
21
#' @export ccRecord
22
#' @examples
23
#' heart_rate <- data.frame(seq(10), rep(70, 10)) # NIHR_HIC_ICU_0108
24
#' site_id <- "Q70" #  NIHR_HIC_ICU_0002
25
#' episode_id <- "0000001" # NIHR_HIC_ICU_0005
26
#'
27
#' # Create a new episode 
28
#' ep <- new.episode(list(NIHR_HIC_ICU_0108=heart_rate, 
29
#'                          NIHR_HIC_ICU_0002=site_id, 
30
#'                          NIHR_HIC_ICU_0005=episode_id)) 
31
#' 
32
#' # modifying records 
33
#' rec <- ccRecord() # a new record 
34
#' rec <- rec + ep # adding a new episode to the record
35
#' rec <- rec + NULL # adding nothing to the record
36
#' rec <- rec + rec # adding a record to a record
37
#' # Adding a list of episodes 
38
#' rec <- ccRecord()
39
#' ep1 <- new.episode()
40
#' ep2 <- new.episode()
41
#' eps.list <- list(ep1, ep2)
42
#' new.rec <- rec + eps.list
43
ccRecord <- setClass("ccRecord", 
44
                      slots=c(nepisodes="integer", dmgtb="data.table", 
45
                              infotb="data.table", episodes="list"),
46
                      prototype=prototype(nepisodes=as.integer(0), 
47
                                          infotb=data.table(), 
48
                                          dmgtb=data.table()))
49

50
#' The S4 class which holds data of a single episode. 
51
#' 
52
#' @field site_id character string. Site ID, if presented, otherwise "NA".
53
#' @field episode_id character string. Episode ID, if presented, otherwise "NA".
54
#' @field nhs_number character string. NHS number, if presented, otherwise "NA".
55
#' @field pas_number character string. PAS number, if presented, otherwise "NA".
56
#' @field parse_file character string. The source XML file. If the source is not a file then "NA".
57
#' @field t_admission POSIXct. Time of Admission to the ICU, if presented, otherwise NA.
58
#' @field t_discharge POSIXct. Time of discharge of the ICU, if presented, otherwise NA.
59
#' @field parse_time POSIXct. Parse time. 
60
#' @field data A list which holds all the data of this episode which is indexed by NIHIC code. 
61
#' @exportClass ccEpisode 
62
ccEpisode <- setClass("ccEpisode", 
63
                       slots=c(site_id="character", 
64
                               episode_id="character",
65
                               nhs_number="character",
66
                               pas_number="character",
67
                               t_admission="POSIXct", 
68
                               t_discharge="POSIXct",
69
                               parse_file="character",
70
                               parse_time="POSIXct", 
71
                               data="list"), 
72

73
                       prototype=prototype(site_id="NA", 
74
                                           episode_id="NA", 
75
                                           nhs_number="NA",
76
                                           pas_number="NA", 
77
                                           t_admission=as.POSIXct(NA), 
78
                                           t_discharge=as.POSIXct(NA), 
79
                                           parse_file="NA",
80
                                           parse_time=as.POSIXct(NA),
81
                                           data=list()))
82

83
index.record <- function(rec) {
84 1
    retrieve_all <- function(x) {
85 1
        .simple.data.frame(list(site_id    = x@site_id, 
86 1
                                episode_id = x@episode_id,
87 1
                                nhs_number = x@nhs_number, 
88 1
                                pas_number = x@pas_number, 
89 1
                                t_admission= x@t_admission, 
90 1
                                t_discharge= x@t_discharge, 
91 1
                                parse_file = x@parse_file, 
92 1
                                parse_time = x@parse_time))
93
    
94
    }
95 1
    rec@nepisodes <- length(rec@episodes)
96 1
    rec@infotb <- rbindlist(for_each_episode(rec, retrieve_all))
97

98
    # id will be filled in the following sequence, NHS number, PAS number,
99
    # site-episode combination and unknown tags. 
100 1
    if (nrow(rec@infotb) > 1) {
101 1
        id <- rec@infotb$nhs_number
102 1
        id[id=="NA"] <- rec@infotb$pas_number[id=="NA"]
103 1
        id[id=="NA"] <- paste(rec@infotb$site_id[id=="NA"], 
104 1
                                rec@infotb$episode_id[id=="NA"],
105 1
                                sep="-")
106 1
        id[id=="NA-NA"] <- paste("unknown", seq(length(which(id=="NA-NA"))))
107 1
        id <- data.table(id=id)
108 1
        id[, "pid":=.GRP, by="id"]
109 1
        rec@infotb[, "pid":=id$pid]
110 1
        rec@infotb[, "index":=seq(nrow(rec@infotb))]
111
    }
112 1
    rec
113
}
114

115
#' Adding a list of ccEpisode to ccRecord
116
#' 
117
#' @description Adding a list of one or multiple ccEpisode objects to a
118
#' ccRecord object, the information table (infotb) will be updated automatically.
119
#' It is the more efficient way to add multiple ccEpisode objects.
120
#' @param e1 ccRecord
121
#' @param e2 a list of ccEpisode objects
122
#' @return ccRecord
123
#' @exportMethod +
124
setMethod('+', c("ccRecord", "list"), 
125
          function(e1, e2) {
126 1
              for(i in seq(length(e2)))
127 1
                  e1@episodes[[length(e1@episodes) + 1]] <- e2[[i]]
128 1
              index.record(e1)
129
         
130
          
131
          })
132

133
#' Adding one ccEpisode object to a ccRecord 
134
#' 
135
#' @param e1 ccRecord-class
136
#' @param e2 ccEpisode-class
137
#' @return ccRecord-class 
138
setMethod('+', c("ccRecord", "ccEpisode"), 
139
          function(e1, e2) {
140 1
              e1@episodes[[length(e1@episodes) + 1]] <- e2
141 1
              index.record(e1)
142
          })
143

144
#' Combine two ccRecord objects 
145
#' 
146
#' @param e1 ccRecord-class
147
#' @param e2 ccRecord-class
148
#' @return ccRecord-class
149
setMethod('+', c("ccRecord", "ccRecord"), 
150
          function(e1, e2) {
151 0
              e1@episodes <- append(e1@episodes, e2@episodes)
152 0
              index.record(e1)
153
          })
154

155
#' Adding nothing to a ccRecord object and return the original ccRecord
156
#' 
157
#' @param e1 ccRecord-class 
158
#' @param e2 NULL 
159
setMethod('+', c("ccRecord", "NULL"), 
160 0
          function(e1, e2) return(e1))
161

162

163
#' Create a new episode
164
#' 
165
#' create a new ccEpisode object by given the episode data as a
166
#' list. The list should be organised in data items and indexed with NIHC code,
167
#' e.g. NIHR_HIC_ICU_0108. 
168
#'
169
#' @param lt is a list
170
#' @param parse_file the file location from which the episode comes from.
171
#' @param parse_time the parse date and time of the episode.
172
#' @return ccEpisode object
173
#' @examples 
174
#' eps <- list()
175
#' eps[["NIHR_HIC_ICU_0018"]] <- data.frame(time=seq(10), rep(70, 10))
176
#' new.episode(eps)
177
#' 
178
#' @export 
179
new.episode <- function(lt=list(), 
180
                        parse_file="NA", 
181
                        parse_time=as.POSIXct(NA)) { 
182 1
    eps <- ccEpisode()
183 1
    eps@data <- lt
184
    
185 1
    short.name <- c("NHSNO", "pasno", "ADNO", "ICNNO")
186 1
    slot.name  <- c("nhs_number", "pas_number", "episode_id", "site_id")
187
    
188
    # character values 
189 1
    for (i in seq(slot.name)) {
190 1
        val <- lt[[stname2code(short.name[i])]]
191 1
        if (is.null(val)) slot(eps, slot.name[i]) <- "NA"
192 1
        else slot(eps, slot.name[i]) <- val
193
    } # Time data 
194 1
    short.name <- c("DAICU", "DDICU")
195 1
    slot.name <- c("t_admission", "t_discharge")
196 1
    for (i in seq(slot.name)) 
197 1
        slot(eps, slot.name[i]) <-
198 1
            as.POSIXct(xmlTime2POSIX(lt[[stname2code(short.name[i])]], allow=TRUE))
199

200 1
    eps@parse_file <- parse_file
201 1
    eps@parse_time <- parse_time 
202 1
    eps
203
}
204

205
#' loop over all episodes of a ccRecord object 
206
#' 
207
#' @param record ccRecord 
208
#' @param fun function 
209
#' @export 
210
for_each_episode <- function(record, fun) {
211 1
    lapply(record@episodes, fun)
212
}
213

214

215
#' Subsetting a ccRecord object and return a list of ccEpisode objects.
216
#' 
217
#' @param x ccRecord-class
218
#' @param i integer vector
219
#' @exportMethod [[
220
setMethod("[[", "ccRecord",
221
          function(x, i) {
222 0
              eplst <- list()
223 0
              for (ep in i) {
224 0
                  eplst[[length(eplst) + 1]] <- x@episodes[[ep]]
225
              }
226 0
              eplst
227
          }
228
)
229

230
#' Create a subset of ccRecord object from the original one via specifying the row number of episodes.
231
#'
232
#' @param x ccRecord-class
233
#' @param i integer vector
234
#' @exportMethod [
235
setMethod("[", "ccRecord",
236
          function(x, i){ 
237 0
              eplst <- list()
238 0
              for (ep in i) {
239 0
                  eplst[[length(eplst) + 1]] <- x@episodes[[ep]]
240
              }
241 0
              ccRecord() + eplst
242
          })
243

244
#' Create a ccRecord subsetting via selected sites.
245
#'
246
#' @param x ccRecord-class
247
#' @param i character vector which contains site_ids, e.g. c("Q70", "Q70W")
248
#' @exportMethod [
249
setMethod("[", signature(x="ccRecord", i="character"), 
250
          definition=function(x, i) {
251 0
              stopifnot(all(i%in%rownames(site.info())))
252 0
              ind <- x@infotb[x@infotb$site_id%in%i]$index
253 0
              if (length(ind) == 0) {
254 0
                  return(ccRecord())
255
              }
256 0
              eplst <- list()
257 0
              for (ep in ind) {
258 0
                  eplst[[length(eplst) + 1]] <- x@episodes[[ep]]
259
              }
260 0
              ccRecord() + eplst
261
          })
262

263

264
episode_graph <- function(ep, items=NULL) {
265 0
    t_ad <- ep@t_admission
266 0
    t_dc <- ep@t_discharge
267

268

269 0
    if (is.null(items))
270 0
        items <- c("h_rate", "spo2", "bilirubin", "platelets", "pao2_fio2", "gcs_total")
271

272 0
    all.drugs <- names(which(class.dict_code[names(ITEM_REF)] == "Drugs"))
273 0
    used.drugs <- code2stname(all.drugs[all.drugs %in% names(ep@data)])
274

275 0
    classification.dictionary <- sapply(ITEM_REF, function(x) x$Classification1)
276

277

278 0
    create.long.table <- function(ep, items) {
279 0
        items <- data.table(items=items, 
280 0
                            code=stname2code(items),
281 0
                            longname=stname2longname(items),
282 0
                            class=classification.dictionary[stname2code(items)])
283 0
        units <- unit.dict[items$code]
284 0
        units[is.na(units)] <- ""
285 0
        items$longname <- paste0(items$longname, "\n", units)
286

287 0
        ltb <- list()
288 0
        for (i in seq(nrow(items))) {
289 0
            if (is.null(ep@data[[items[i]$code]]))
290 0
                ltb[[i]] <- data.frame()
291
            else
292 0
                ltb[[i]] <- data.frame(ep@data[[items[i]$code]], 
293 0
                                       item=items[i]$longname)
294
        }
295 0
        ltb <- rbindlist(ltb, use.names=TRUE, fill=TRUE)
296 0
        if (is.numeric(ltb$time))
297 0
            ltb$time <- t_ad + ltb$time * 60 * 60
298 0
        ltb$item2d <- as.numeric(ltb$item2d)
299 0
        return(ltb)
300
    }
301

302 0
    physio.tb <- create.long.table(ep, items)
303 0
    physio.tb <- data.frame(physio.tb, 
304 0
                            catg1=physio.tb$item, 
305 0
                            catg2="Physiology Data")
306 0
    drug.tb <- create.long.table(ep, used.drugs)
307

308 0
    drug.tb <- data.frame(drug.tb, catg1="Drugs", 
309 0
                          catg2=drug.tb$item)
310

311

312 0
    tb <- rbindlist(list(physio.tb, drug.tb), fill=TRUE, use.names=TRUE)
313

314

315 0
    ggp <- ggplot(tb, aes_string(x="time", y="item2d", group="item",
316 0
                                 colour="catg2")) + geom_line(colour="#1E506C") + 
317 0
        geom_point(size=1) + 
318 0
        facet_grid(catg1 ~., scales="free_y") + 
319 0
        geom_vline(xintercept = as.numeric(t_ad), colour="#D1746F") + 
320 0
        geom_vline(xintercept = as.numeric(t_dc), colour="#D1746F") + 
321 0
        scale_colour_manual(values=c("#1E506C", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#FFFFFF"), 
322 0
                            name=paste0(ep@episode_id, "_", ep@site_id, "\n", 
323 0
                                       icnarc2diagnosis(ep@data[[stname2code('RAICU1')]]), "\n\n")) +  
324 0
        theme(legend.title = element_text(size=8), 
325 0
              legend.text  = element_text(size=8)) +
326 0
                            labs(x="", y="")
327

328

329

330 0
    graphics::plot(ggp)
331
    #"#1E506C""#D1746F"
332 0
    invisible(tb)
333
}
334

335
#' Individual episode chart
336
#' 
337
#' Create an individual episode chart for its diagnosis, drugs and physiological
338
#' variables. Diagnosis and drugs are always included, while the user can
339
#' select other longitudinal data. 
340
#' @param r ccEpisode-class
341
#' @param v short name of longitudinal data. While v is not given, the chart 
342
#' will only display h_rate, spo2, bilirubin, platelets, pao2_fio2, gcs_total. 
343
#' @return a table of selected vars of an episode
344
#' @exportMethod plot_episode
345
#' @examples
346
#' \dontrun{
347
#' plot_episode(ccd@episodes[[1]]) # plot first episode with default variables. 
348
#' plot_episode(ccd@episodes[[1]], "h_rate") # plot first episode heart rate
349
#' }
350
setGeneric("plot_episode", function(r, v) {
351 0
    standardGeneric("plot_episode")
352
})
353

354
#' Episode chart
355
#' 
356
#' @param r ccEpisode-class
357
#' @param v character 
358
setMethod("plot_episode", signature(r="ccEpisode", v="character"), 
359
function(r, v){
360 0
    episode_graph(r, v)
361
})
362

363

364
#' Episode chart default fields
365
#' 
366
#' @param r ccEpisode-class
367
setMethod("plot_episode", signature(r="ccEpisode", v="missing"), 
368
function(r) {
369 0
    episode_graph(r)
370
})

Read our documentation on viewing source code .

Loading