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 2
  v.vec = data[[vname]]
17 2
  out = ""
18 2
  if (is.numeric(v.vec)){
19 2
    out = c(vname, class(v.vec), NA)
20
  } else{
21 2
    v.level = levels(v.vec)
22 2
    nr = length(v.level)
23 2
    out = cbind(rep(vname, nr), rep(class(v.vec), nr), v.level)
24
  }
25 2
  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 2
  variable <- level <- val_label <- NULL
44
  
45 2
  out.list = lapply(names(data), function(x){mk.lev.var(data, x)})
46 2
  out.dt = data.table::data.table(Reduce(rbind, out.list))
47 2
  names(out.dt) = c("variable", "class","level")
48 2
  out.dt[, var_label := variable]
49 2
  out.dt[, val_label := level]
50 2
  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 2
  lv2 <- variable <- level <- val_label <- NULL
78
  
79 2
  tb.main <- epiDisplay.obj$table
80 2
  tb.compact <- tb.main[!rownames(tb.main)=="", ]
81 2
  if (nrow(tb.main)  <= 2){
82 0
    tb.compact <- tb.main
83
  }
84

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

148

149

150

151

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

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

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

231

232

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

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

265

266

267

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

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

299

300

301

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

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

340

341

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

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

383

384

385

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

403
LabeljsGeeglm = function(obj, ref){
404
  
405 2
  variable <- NULL
406
  
407 2
  out <- list()
408 2
  out$table <- LabeljsTable(obj$table, ref = ref)
409 2
  out$metric <- obj$metric
410 2
  out$caption <- obj$caption
411 2
  cap.split <- strsplit(obj$caption, "predicting ")[[1]]
412 2
  yxc <- cap.split[2]
413 2
  yxc1 <- strsplit(yxc, " by ")[[1]]
414 2
  y <- yxc1[1]
415 2
  x <- strsplit(yxc1[2], " - Group ")[[1]]
416 2
  xx <- strsplit(x[1], ", ")[[1]]
417 2
  xc <- x[2]
418 2
  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="") 
419
  
420 2
  return(out)
421
}
422

423

Read our documentation on viewing source code .

Loading