1
# get indexing tables for time label, time-wise value, 
2
# meta data label, and meta data.  Return a list of vectors 
3
# contains time.index, datat.index, meta.index,
4
# datam.index
5
extract_index_table <- function() {
6 1
    info <- extract_info()
7

8 1
    checklist <- list()
9 1
    for(i in seq(info$nontime))
10 1
        checklist[[info$nontime[i]]] <- "item1d"
11 1
    for(i in seq(info$time$idt))
12 1
        checklist[[info$time$idt[i]]] <- "time"
13 1
    for(i in seq(info$time$id))
14 1
        checklist[[info$time$id[i]]] <- "item2d"
15 1
    for(i in seq(info$meta$meta))
16 1
        checklist[[info$meta$meta[i]]] <- "meta"
17
    
18 1
    return(checklist)
19
}
20

21

22
# This is a simplified version of as.data.frame() with better performance. 
23
.simple.data.frame <- function(x) {
24 1
    nm <- names(x)
25 1
    attr(x, "row.names") <- .set_row_names(length(x[[1]]))
26 1
    attr(x, "col.names") <- nm
27 1
    class(x) <- "data.frame"
28 1
    x
29
}
30

31

32

33
.which.type <- function(id) {
34 1
    return(checklist[[id]])
35
}
36

37

38
.which.datatype <- function(id) {
39
  # List with the conversion operations to do for each data type
40 1
  operations <- list('numeric' = as.numeric,
41 1
                     'text' = as.character,
42 1
                     'date' = as.character, # They are hashed for now
43 1
                     'time' = as.character, # They are hashed for now
44 1
                     'logical' = as.logical,
45 1
                     'list' = as.character,
46 1
                     'date/time' = as.character, # They are hashed for now
47 1
                     'list / logical' = as.character) # what are they?
48

49 1
  datatype <- ITEM_REF[[id]]$Datatype
50 1
  if (!is.null(datatype)){
51 1
    if (exists(datatype, operations)){
52 1
      return(operations[[datatype]])
53
    }
54
  }
55
  # accounts for not listed or null (eg. when working with dt labels)
56 0
  return(as.character)
57
}
58

59
#' give id number from NHIC code like "NIHR_HIC_ICU_xxxx"
60
#' @param nhic NHIC code
61
whichIsCode <- function(nhic) {
62 1
    return(grepl(nhic, pattern="[0-9][0-9][0-9][0-9]"))
63
}
64

65
#' Extract information from data.checklist
66
#' 
67
#' @return list of time [data.frame(id, idt)], meta [data.frame(id, idmeta)], 
68
#'         nontime [numeric], MAX_NUM_NHIC
69
#' @export 
70
extract_info <- function() {
71 1
    index.time <- whichIsCode(data.checklist$NHICdtCode) 
72 1
    index.meta <- whichIsCode(data.checklist$NHICmetaCode)
73

74 1
    item.labels <- StdId(data.checklist$NHICcode[index.time])
75 1
    time.labels <- StdId(data.checklist$NHICdtCode[index.time])
76

77 1
    metaitem.labels <- StdId(data.checklist$NHICcode[index.meta])
78 1
    meta.labels <- StdId(data.checklist$NHICmetaCode[index.meta])
79
    
80 1
    time.list <-
81 1
        data.frame(id=item.labels@ids, idt=time.labels@ids,
82 1
                   stringsAsFactors=FALSE)
83 1
    meta.list <- data.frame(id=metaitem.labels@ids, meta=meta.labels@ids,
84 1
                            stringsAsFactors=FALSE)
85
    
86
    
87 1
    nontime<- StdId(data.checklist$NHICcode[!index.time])
88
    # get all ids which should be the assemble of NHICcode and NHICmetaCode
89 1
    all.nhic.code <- StdId(data.checklist$NHICcode)
90 1
    all.ids <- c(meta.list$idmeta,
91 1
                 all.nhic.code@ids)
92 1
    if (any(duplicated(all.ids)))
93 0
        stop("data.checklist.RData error! meta data code and NHICcode are overlaped")
94 1
    return(list(time=time.list, meta=meta.list, nontime=nontime@ids,
95 1
                MAX_NUM_NHIC=max(as.numeric(as.number(all.nhic.code)), 
96 1
                                 as.numeric(as.number(StdId(time.list$idt))))))
97
}
98

99
#' Lookup items information by keywords
100
#' 
101
#' This function tries to match keywords in short names, long names and NHIC code. 
102
#' The matched items will be displayed. 
103
#' @param keyword character e.g. "h_rate", "heart", "108".
104
#' @param style character, the style of the table output which can be "simple",
105
#' "rmarkdown", and "grid"
106
#' @return character the short names of the selected items.
107
#' @export lookup.items
108
lookup.items <- function(keyword, style="grid") {
109
    
110 1
    index1 <- grep(keyword, stname2longname.dict, ignore.case=TRUE)
111 1
    index2 <- grep(keyword, names(stname2longname.dict), ignore.case=TRUE)
112 1
    index3 <- grep(keyword, stname2code(names(stname2longname.dict)), ignore.case=TRUE)
113

114

115 1
    stn <- unique(names(stname2longname.dict[c(index1, index2, index3)]))
116 1
    query_item_ref <- function(stn, field)
117 1
        unlist(sapply(ITEM_REF[stname2code(stn)], 
118 1
                      function(x) ifelse(is.null(x[[field]]), "N/A", x[[field]])))
119

120 1
    tb <- data.frame("NHIC Code"=stname2code(stn), 
121 1
               "Short Name"=stn, 
122 1
               "Long Name"=stname2longname(stn), 
123 1
               "Unit"=query_item_ref(stn, "Units"), 
124 1
               "Data type"=query_item_ref(stn, "Datatype")) 
125 1
    rownames(tb) <- NULL
126 1
    pander(tb, style=style, split.table = Inf)
127 1
    invisible(tb[, 2])
128
}
129

130

131
#' Convert time from xml to POSIX format.
132
#'
133
#' Convert the XML time The XML time format to POSIXct. 
134
#' @param xml.time character. Time in XML format such as 2014-02-01T03:00:00
135
#' @param allow logical. Wrong format will be accepted when \code{allow} is set
136
#' to be TRUE and NA will be the return value, otherwise return error. 
137
#' It is useful while dealing with pseudonymous data where the time format is
138
#' not presented correctly. 
139
#' 
140
#' @export
141
xmlTime2POSIX <- function(xml.time, allow=FALSE){
142 1
    if (is.null(xml.time))
143 1
        return(NA)
144 1
    tp <- as.POSIXct(xml.time, "GMT", format="%Y-%m-%dT%H:%M:%S")
145 1
    tp[is.na(tp)] <- as.POSIXct(xml.time[is.na(tp)], "GMT", format="%Y-%m-%d")
146 1
    if (!allow) {
147 1
        if(any(is.na(tp)))
148 0
            stop(xml.time[is.na(tp)])
149
    }
150 1
    return(tp)
151
}
152

153
#' Produce a site id reference table.
154
#'
155
#' @return data.frame 
156
#' @export site.info
157
site.info <- function(){
158 1
    si <- list(
159 1
               "D20N"=c("Addenbrooke's Hospital", "Neuro", "Cambridge", ""),  
160 1
               "D20"=c("Addenbrooke's Hospital", "ICU/HDU", "Cambridge", "John Farnham"), 
161 1
               "K32"=c("Guy's Hospital", "ICU", "GSTT", ""),   
162 1
               "V47"=c("St Thomas' Hospital", "ICU/HDU", "GSTT", ""),   
163 1
               "H09"=c("St Thomas' Hospital", "OIR", "GSTT", "overnight intensive recovery"), 
164 1
               "Z89"=c("St Thomas' Hosptial", "HDU", "GSTT", "page and victoria"), 
165 1
               "C90"=c("Hammersmith Hospital", "ICU/HDU", "Imperial", ""),  
166 1
               "Q13"=c("St Mary's Hospital London", "ICU", "Imperial", "Milne Ward"),
167 1
               "S28"=c("John Radcliffe", "ICU", "Oxford", ""),
168 1
               "F42"=c("Oxford Neuro", "", "Oxford", "no data"),
169 1
               "F54"=c("Oxford Horton", "", "Oxford", "no data because not on ICIP"),
170 1
               "Q70"=c("University College Hospital", "ICU/HDU", "UCLH", ""),
171 1
               "Q70W"=c("Westmoreland Street", "ICU/HDU", "UCLH", ""),   
172 1
               "R42"=c("Unknown", "Unknown", "Unknown", "Unknown"),
173 1
               "X90"=c("Addenbrooke's Hospital", "General/Liver/Transplant",  "Cambridge", "John Farnham")
174
               )
175 1
    si <- data.frame(t(.simple.data.frame(si)), stringsAsFactors=FALSE)
176 1
    names(si) <- c("Hospital", "Unit", "Trust", "Comments")
177 1
    return(si)
178
}
179

180
#' Convert ICNARC codes to diagnosis (text)
181
#' 
182
#' NOTE: There are still ~600 code missing. see issue #133
183
#' @param icnarc the ICNARC code, e.g. 1.1.1.1.1
184
#' @param levels category level, from [1 - 5]. TODO level 4. 
185
#' @param surgery T/F with or without surgical information 
186
#' @return character ICNARC diagnosis
187
#' @export 
188
icnarc2diagnosis <- function(icnarc, surgery=TRUE, levels=NULL) {
189 0
    if (is.null(icnarc)) return("NA")
190
    # e.g 1.01.1 -> 1.1.1
191 1
    if(!is.null(levels))
192 1
        icnarc <- icnarc.breakdown(icnarc, digits=levels)
193
    else 
194 1
        icnarc <- vapply(lapply(strsplit(icnarc, split='[.]'), as.numeric), 
195 1
          function(x) paste(x, collapse="."), character(1))
196

197 1
    diag <- as.character(icnarc.dict[icnarc])
198 1
    if (!surgery)
199 1
        return(gsub(x=diag, " [(]Surgical[)]| [(]Nonsurgical[)]", ""))
200
    else
201 1
        return(diag)
202
}
203

204
icnarc.breakdown <- function(r, digits=3) {
205 1
    cols <- strsplit(r, '[.]')
206 1
    cols <- lapply(cols, 
207 1
           function(x) {
208 1
               x <- tryCatch(as.numeric(x), 
209 1
                             warning=function(w) {
210 0
                                 return(NA)
211
                             })
212 1
               if (length(x) < 5)
213 1
                   x <- c(x, rep(NA, 5-length(x)))
214 1
               if (length(x) > 5)
215 0
                   x <- x[1:5]
216 1
               x
217
           })
218
    
219 1
    cols <- t(data.frame(cols))
220 1
    rownames(cols) <- seq(nrow(cols))
221 1
    cols <- cols[, 1:digits]
222

223 1
    combine <- function(x) {
224 1
        x <- x[!is.na(x)]
225 1
        paste(x, collapse=".")
226
    }
227 1
    if (digits == 1) return(as.character(cols))
228 1
    if (class(cols) == "numeric") 
229 1
        return(combine(cols))
230
    else
231 1
        return(apply(cols, 1, combine))
232
}

Read our documentation on viewing source code .

Loading