1
## Label data 
2

3

4
#' @title Export label and level: one variable
5
#' @description Export label and level: one variable
6
#' @param data data
7
#' @param vname variable to export label and level
8
#' @return if continuous variable - (label, NA), categorical variable - (label, level)
9
#' @details DETAILS
10
#' @examples 
11
#'  lapply(names(iris), function(x){jstable::mk.lev.var(iris, x)})
12
#' @rdname mk.lev.var
13
#' @export 
14

15
mk.lev.var = function(data , vname){
16 1
  v.vec = data[[vname]]
17 1
  out = ""
18 1
  if (is.numeric(v.vec)){
19 1
    out = c(vname, class(v.vec), NA)
20
  } else{
21 1
    v.level = levels(v.vec)
22 1
    nr = length(v.level)
23 1
    out = cbind(rep(vname, nr), rep(class(v.vec), nr), v.level)
24
  }
25 1
  return(out)
26
}
27

28

29

30
#' @title Export label and level: multiple variable
31
#' @description Export label and level: multiple variable
32
#' @param data data
33
#' @return default label and level data
34
#' @details DETAILS
35
#' @examples 
36
#'  mk.lev(iris)
37
#' @rdname mk.lev
38
#' @export 
39
#' @importFrom data.table data.table :=
40

41
mk.lev = function(data){
42
  
43 1
  variable <- level <- val_label <- NULL
44
  
45 1
  out.list = lapply(names(data), function(x){mk.lev.var(data, x)})
46 1
  out.dt = data.table::data.table(Reduce(rbind, out.list))
47 1
  names(out.dt) = c("variable", "class","level")
48 1
  out.dt[, var_label := variable]
49 1
  out.dt[, val_label := level]
50 1
  return(out.dt[])
51
}
52

53

54

55

56

57

58
#' @title LabelepiDisplay: Apply label information to epiDisplay object using label data
59
#' @description Apply label information to epiDisplay.object using label data
60
#' @param epiDisplay.obj epiDisplay.object or glmshow.object
61
#' @param label Apply label information, Default: F
62
#' @param ref Label data made by mk.lev function
63
#' @return epiDisplay.object with label information
64
#' @details DETAILS
65
#' @examples 
66
#'  fit <- glm(Sepal.Length ~ Sepal.Width + Species, data = iris)
67
#'  fit.table <- glmshow.display(fit)
68
#'  iris.label <- mk.lev(iris)
69
#'  LabelepiDisplay(fit.table, label = TRUE, ref = iris.label)
70
#' @rdname LabelepiDisplay
71
#' @export 
72
#' @importFrom data.table data.table :=
73

74

75
LabelepiDisplay = function(epiDisplay.obj, label = F, ref){
76
  
77 1
  lv2 <- variable <- level <- val_label <- NULL
78
  
79 1
  tb.main <- epiDisplay.obj$table
80 1
  tb.compact <- tb.main[!rownames(tb.main)=="", ]
81 1
  if (nrow(tb.main)  <= 2){
82 0
    tb.compact <- tb.main
83
  }
84

85
  
86
  ## Var label
87 1
  tb.rn = gsub(" \\(cont. var.\\)", "", rownames(tb.compact))
88 1
  rownames(tb.compact) <- tb.rn
89
 
90 1
  if (nrow(tb.main) < 2 & label == T){
91 0
    vname <- strsplit(rownames(tb.compact)[1], ":")[[1]][1]
92 0
    cond.lv2 <- grepl(":", rownames(tb.compact)[1]) & grepl("vs", rownames(tb.compact)[1])
93 0
    rownames(tb.compact) <- gsub(vname, ref[variable == vname, var_label][1], rownames(tb.compact))
94 0
    if (cond.lv2){
95 0
      vll <- ref[variable == vname & level %in% lv2, c("level", "val_label")]
96 0
      rownames(tb.compact) <- gsub(paste(vll[level == lv2[1], level], " vs ", vll[level == lv2[2], level], sep=""), paste(vll[level == lv2[1], val_label], " vs ", vll[level == lv2[2], val_label], sep=""), rownames(tb.compact))
97
    }
98
  }
99
  
100 1
  if (nrow(tb.main) > 2 & label == T){
101 1
    vn <- which(substr(tb.rn, 1, 1) != " ")
102 1
    vns <- c(vn, length(tb.rn)+1 )
103 1
    vl <- lapply(1:length(vn), function(x){tb.rn[vns[x]:(vns[x+1]-1)]})
104 1
    vl_label <- lapply(vl, function(x){
105 1
      vname <- strsplit(x[1], ":")[[1]][1]
106 1
      cond.lv2 <- grepl(":", x[1]) & grepl("vs", x[1])
107
      #x[1] <- gsub(vname, ref[variable == vname, var_label][1], x[1])
108 1
      if (cond.lv2){
109 0
        lv2 <- strsplit(strsplit(x[1], ": ")[[1]][[2]], " vs ")[[1]]
110 0
        vll <- ref[variable == vname & level %in% lv2, c("level", "val_label")]
111 0
        x <- paste(ref[variable == vname, var_label][1], ": ", vll[level == lv2[1], val_label], " vs ", vll[level == lv2[2], val_label], sep = "")
112
        #x = gsub(paste(vll[2, 1], " vs ", vll[1,1], sep=""), paste(vll[2, 2], " vs ", vll[1,2], sep=""), x)
113 1
      } else if (ref[variable == vname, class][1] %in% c("factor", "character")){
114 1
        x[1] <- paste(ref[variable == vname, var_label][1], ": ref.=", ref[variable == vname & level == strsplit(x[1], "\\.\\=")[[1]][2], val_label], sep = "")
115 1
        for (k in 2:length(x)){
116 1
          x[k] <- paste("   ", ref[variable == vname & level == strsplit(x[k], "   ")[[1]][2], val_label], sep = "")
117
        }
118
        
119
        #for (y in ref[variable == vname, level]) {x = gsub(y, ref[variable == vname & level == y, val_label], x)}
120
      }
121 1
      return(x)
122
    })
123 1
    rownames(tb.compact) <- unlist(vl_label)
124
  }
125
  
126 1
  ll <- strsplit(epiDisplay.obj$last.lines,"\n")[[1]]
127 1
  ll.vec <- matrix(unlist(lapply(ll,function(x){strsplit(x," = ")})), ncol =2, byrow=T)
128 1
  ll.mat <- matrix(rep("", nrow(ll.vec)* ncol(tb.compact)), nrow = nrow(ll.vec))  
129 1
  ll.mat[,1] = ll.vec[,2]
130 1
  rownames(ll.mat) <- ll.vec[,1]
131 1
  out <- rbind(tb.compact, rep("", ncol(tb.compact)), ll.mat)
132
  
133 1
  if (nrow(tb.main) == 2){
134 0
    out <- rbind(tb.compact, ll.mat)
135
  }
136
  
137 1
  p.colnum <- which(colnames(out) %in% c("P value", "adj. P value", "P(t-test)", "P(Wald's test)")) 
138 1
  p.colnum <- p.colnum[length(p.colnum)]
139
  
140 1
  pn <- gsub("< ","", out[, p.colnum])
141
  
142 1
  colnames(out)[p.colnum] <- ifelse(colnames(out)[p.colnum] == "P value", "P value", "adj. P value")
143 1
  sig <- ifelse(as.numeric(pn) <= 0.05, "**", "")
144 1
  return(cbind(out,sig))
145
}
146

147

148

149

150

151
#' @title LabeljsTable: Apply label information to jstable object using label data
152
#' @description Apply label information to table of geeglm.display, lmer.display, coxme.display using label data
153
#' @param obj.table table of geeglm.display, lmer.display, coxme.display
154
#' @param ref Label data made by mk.lev function
155
#' @return table of geeglm.display, lmer.display, coxme.display with label information
156
#' @details DETAILS
157
#' @examples 
158
#'  library(coxme)
159
#'  fit <- coxme(Surv(time, status) ~ sex + ph.ecog + ph.karno + (1|inst) +(1|sex), lung)
160
#'  fit.table <- coxme.display(fit)
161
#'  lung.label <- mk.lev(lung)
162
#'  LabeljsTable(fit.table$table, ref = lung.label)
163
#' @rdname LabeljsTable
164
#' @export 
165
#' @importFrom data.table data.table :=
166

167
LabeljsTable = function(obj.table, ref){
168
  
169 1
  lv2 <- variable <- level <- val_label <- NULL
170
  
171 1
  tb.main <- obj.table
172 1
  tb.compact <- tb.main
173
  
174
  ## Var label
175 1
  tb.rn <- rownames(tb.compact)
176

177 1
  if (nrow(tb.main) == 1){
178
    
179 0
    vname <- strsplit(rownames(tb.compact)[1], ":")[[1]][1]
180 0
    cond.lv2 <- grepl(":", rownames(tb.compact)[1]) & grepl("vs", rownames(tb.compact)[1])
181 0
    rownames(tb.compact) <- gsub(vname, ref[variable == vname, var_label][1], rownames(tb.compact))
182 0
    if (cond.lv2){
183 0
      vll <- ref[variable == vname & level %in% lv2, c("level", "val_label")]
184 0
      rownames(tb.compact) <- gsub(paste(vll[level == lv2[1], level], " vs ", vll[level == lv2[2], level], sep=""), paste(vll[level == lv2[1], val_label], " vs ", vll[level == lv2[2], val_label], sep=""), rownames(tb.compact))
185
    }
186
    
187
  }
188
  
189 1
  if (nrow(tb.main) > 1){
190 1
    vn <- which(substr(tb.rn, 1, 1) != " ")
191 1
    vns <- c(vn, length(tb.rn)+1 )
192 1
    vl <- lapply(1:length(vn), function(x){tb.rn[vns[x]:(vns[x+1]-1)]})
193 1
    vl_label = lapply(vl, function(x){
194 1
      vname <- strsplit(x[1], ":")[[1]][1]
195 1
      x[1] <- gsub(vname, ref[variable == vname, var_label][1], x[1])
196 1
      cond.lv2 <- grepl(":", x[1]) & grepl("vs", x[1])
197
      #x[1] <- gsub(vname, ref[variable == vname, var_label][1], x[1])
198 1
      if (cond.lv2){
199 0
        lv2 <- strsplit(strsplit(x[1], ": ")[[1]][[2]], " vs ")[[1]]
200 0
        vll <- ref[variable == vname & level %in% lv2, c("level", "val_label")]
201 0
        x <- paste(ref[variable == vname, var_label][1], ": ", vll[level == lv2[1], val_label], " vs ", vll[level == lv2[2], val_label], sep = "")
202
        #x = gsub(paste(vll[2, 1], " vs ", vll[1,1], sep=""), paste(vll[2, 2], " vs ", vll[1,2], sep=""), x)
203 1
      } else if (ref[variable == vname, class][1] %in% c("factor", "character")){
204 1
        x[1] <- paste(ref[variable == vname, var_label][1], ": ref.=", ref[variable == vname & level == strsplit(x[1], "\\.\\=")[[1]][2], val_label], sep = "")
205 1
        for (k in 2:length(x)){
206 1
          x[k] <- paste("   ", ref[variable == vname & level == strsplit(x[k], "   ")[[1]][2], val_label], sep = "")
207
        }
208
        
209
        #for (y in ref[variable == vname, level]) {x = gsub(y, ref[variable == vname & level == y, val_label], x)}
210
      }
211 1
      return(x)
212
    })
213 1
    rownames(tb.compact) = unlist(vl_label)
214
  }
215
  
216 1
  out <- tb.compact
217
  #sig.colnum = which(colnames(out) %in% c("P value", "adj. P value")) 
218
  #pn = gsub("< ","", out[, sig.colnum])
219
  #sig = ifelse(as.numeric(pn) <= 0.05, "**", "")
220
  
221
  #pv.colnum = which(colnames(out) %in% c("P value", "crude P value", "adj. P value"))
222
  #for (i in pv.colnum){
223
  #  out[, i] = ifelse(as.numeric(out[, i]) < 0.001, "< 0.001", round(as.numeric(out[, i]), 3))
224
  #}
225 1
  return(out)
226
}
227
  
228

229

230

231
#' @title LabeljsRanef: Apply label information to jstable random effect object using label data
232
#' @description Apply label information to ranef object of jstable using label data
233
#' @param obj.ranef ranef of lmer.display, coxme.display, cox2.display
234
#' @param ref Label data made by mk.lev function
235
#' @return ranef of lmer.display, coxme.display, cox2.display with label information
236
#' @details DETAILS
237
#' @examples 
238
#'  library(coxme)
239
#'  fit <- coxme(Surv(time, status) ~ sex + ph.ecog + ph.karno + (1|inst) +(1|sex), lung)
240
#'  fit.table <- coxme.display(fit)
241
#'  lung.label <- mk.lev(lung)
242
#'  LabeljsTable(fit.table$table, ref = lung.label)
243
#'  LabeljsRanef(fit.table$ranef, ref = lung.label)
244
#' @rdname LabeljsRanef
245
#' @export 
246

247
LabeljsRanef = function(obj.ranef, ref){
248
  
249 1
  variable <- NULL
250
  
251 1
  ranef <- obj.ranef
252 1
  ranef.split <- strsplit(rownames(ranef)[-1], "\\(")
253 1
  ranef.vname <- unlist(lapply(ranef.split, function(x){x[[1]]}))
254 1
  ranef.vname.label <- sapply(ranef.vname, function(x){ref[variable == x, var_label][1]})
255 1
  if (length(ranef.split) ==1){
256 1
    rownames(ranef)[-1] <- ranef.vname.label
257
  } else{
258 1
    rownames(ranef)[-1] <- paste(ranef.vname.label, "(", unlist(lapply(ranef.split, function(x){x[[2]]})), sep="")
259
  }
260 1
  return(ranef)
261
}
262

263

264

265

266
#' @title LabeljsMetric: Apply label information to jstable metric object using label data
267
#' @description Apply label information to metric object of jstable using label data
268
#' @param obj.metric metric of lmer.display, coxme.display
269
#' @param ref Label data made by mk.lev function
270
#' @return metric of lmer.display, coxme.display with label information
271
#' @details DETAILS
272
#' @examples 
273
#'  library(coxme)
274
#'  fit <- coxme(Surv(time, status) ~ sex + ph.ecog + ph.karno + (1|inst) +(1|sex), lung)
275
#'  fit.table <- coxme.display(fit)
276
#'  lung.label <- mk.lev(lung)
277
#'  LabeljsTable(fit.table$table, ref = lung.label)
278
#'  LabeljsRanef(fit.table$ranef, ref = lung.label)
279
#'  LabeljsMetric(fit.table$metric, ref = lung.label)
280
#' @rdname LabeljsMetric
281
#' @export 
282

283
LabeljsMetric = function(obj.metric, ref){
284
  
285 1
  variable <- NULL
286
  
287 1
  metric <- obj.metric
288 1
  rname <- rownames(metric)
289 1
  group.rnum <- grep("No. of group", rname)
290 1
  group.vars <- unlist(lapply(strsplit(rname[group.rnum], "\\("), function(x){x[[2]]}))   
291 1
  group.vname <- unlist(strsplit(group.vars, "\\)"))
292 1
  group.vname.label <- sapply(group.vname, function(x){ref[variable == x, var_label][1]})
293 1
  rownames(metric)[group.rnum] <- paste("No. of group(", group.vname.label, ")", sep="")
294 1
  return(metric)
295
}
296

297

298

299

300
#' @title LabeljsMixed: Apply label information to jstable object using label data
301
#' @description Apply label information to object of jstable using label data
302
#' @param obj lmer.display, coxme.display
303
#' @param ref Label data made by mk.lev function
304
#' @return lmer.display, coxme.display with label information
305
#' @details DETAILS
306
#' @examples 
307
#'  library(coxme)
308
#'  fit <- coxme(Surv(time, status) ~ sex + ph.ecog + ph.karno + (1|inst) +(1|sex), lung)
309
#'  fit.table <- coxme.display(fit)
310
#'  lung.label <- mk.lev(lung)
311
#'  LabeljsMixed(fit.table, ref = lung.label)
312
#' @rdname LabeljsMixed
313
#' @export 
314

315
LabeljsMixed = function(obj, ref){
316
  
317 1
  variable <- NULL
318
  
319 1
  out <- list()
320 1
  out$table <- LabeljsTable(obj$table, ref = ref)
321 1
  out$ranef <- LabeljsRanef(obj$ranef, ref = ref)
322 1
  out$metric <- LabeljsMetric(obj$metric, ref = ref)
323 1
  out$caption <- obj$caption
324 1
  if (grep("Mixed effects Cox model", obj$caption) == 1){
325 1
    surv.vname <- strsplit(obj$caption, "'")[[1]][c(2,4)]
326 1
    for (vn in surv.vname){
327 1
      out$caption <- gsub(paste("'", vn, "'", sep = ""), paste("'", ref[variable == vn, var_label][1], "'", sep = ""), out$caption)
328
    }
329 1
    group.vname.comma <- strsplit(obj$caption, "- Group ")[[1]][2]
330 1
    group.vname <- strsplit(group.vname.comma, ", ")[[1]]
331 1
    group.vname.label <- sapply(group.vname, function(x){ref[variable == x, var_label][1]})
332 1
    out$caption <- gsub(group.vname.comma, paste(group.vname.label, collapse = ", "), out$caption)
333
  }
334
  
335 1
  return(out)
336
}
337

338

339

340
#' @title LabeljsCox: Apply label information to cox2.display object using label data
341
#' @description Apply label information to cox2.display object using label data
342
#' @param obj cox2.display object
343
#' @param ref Label data made by mk.lev function
344
#' @return cox2.display object with label information
345
#' @details DETAILS
346
#' @examples 
347
#'  library(survival)
348
#'  fit <- coxph(Surv(time, status) ~ sex + ph.ecog + ph.karno + cluster(inst), 
349
#'                data = lung, model = TRUE)
350
#'  fit.table <- cox2.display(fit)
351
#'  lung.label <- mk.lev(lung)
352
#'  LabeljsCox(fit.table, ref = lung.label)
353
#' @rdname LabeljsCox
354
#' @export 
355

356
LabeljsCox = function(obj, ref){
357
  
358 1
  variable <- NULL
359
  
360 1
  out <- list()
361 1
  out$table <- LabeljsTable(obj$table, ref = ref)
362 1
  if (!is.null(obj$ranef)){
363 1
    out$ranef <- LabeljsRanef(obj$ranef, ref = ref)
364
  }
365 1
  out$metric <- obj$metric
366 1
  out$caption <- obj$caption
367 1
  surv.vname <- strsplit(obj$caption, "'")[[1]][c(2,4)]
368 1
  for (vn in surv.vname){
369 1
    out$caption <- gsub(paste("'", vn, "'", sep = ""), paste("'", ref[variable == vn, var_label][1], "'", sep = ""), out$caption)
370
  }
371 1
  if (length(grep("- Group", obj$caption)) >= 1){
372 1
    group.vname.comma <- strsplit(obj$caption, "- Group ")[[1]][2]
373 1
    group.vname <- strsplit(group.vname.comma, ", ")[[1]]
374 1
    group.vname.label <- sapply(group.vname, function(x){ref[variable == x, var_label][1]})
375 1
    out$caption <- gsub(group.vname.comma, paste(group.vname.label, collapse = ", "), out$caption)
376
  }
377
  
378 1
  return(out)
379
}
380

381

382

383

384
#' @title LabeljsGeeglm: Apply label information to geeglm.display object using label data
385
#' @description Apply label information to geeglm.display object using label data
386
#' @param obj geeglm.display object
387
#' @param ref Label data made by mk.lev function
388
#' @return geeglm.display object with label information
389
#' @details DETAILS
390
#' @examples 
391
#'  library(geepack);library(jstable)
392
#'  data(dietox)
393
#'  dietox$Cu <- as.factor(dietox$Cu)
394
#'  gee01 <- geeglm (Weight ~ Time + Cu , id =Pig, data = dietox,
395
#'                 family=gaussian,corstr="ex")
396
#'  g1 <- geeglm.display(gee01)
397
#'  LabeljsGeeglm(g1, ref = mk.lev(dietox))
398
#' @rdname LabeljsGeeglm
399
#' @export 
400

401
LabeljsGeeglm = function(obj, ref){
402
  
403 1
  variable <- NULL
404
  
405 1
  out <- list()
406 1
  out$table <- LabeljsTable(obj$table, ref = ref)
407 1
  out$metric <- obj$metric
408 1
  out$caption <- obj$caption
409 1
  cap.split <- strsplit(obj$caption, "predicting ")[[1]]
410 1
  yxc <- cap.split[2]
411 1
  yxc1 <- strsplit(yxc, " by ")[[1]]
412 1
  y <- yxc1[1]
413 1
  x <- strsplit(yxc1[2], " - Group ")[[1]]
414 1
  xx <- strsplit(x[1], ", ")[[1]]
415 1
  xc <- x[2]
416 1
  out$caption <- paste(cap.split[1], "predicting ", ref[variable == y, var_label][1], " by ", paste(sapply(xx, function(vn){ref[variable == vn, var_label][1]}), collapse = ", "), " - Group ", ref[variable == xc, var_label][1], sep="") 
417
  
418 1
  return(out)
419
}
420

421

Read our documentation on viewing source code .

Loading