Skip to content

Commit ed90290

Browse files
jinseob2kimjinseob2kim
authored
Merge pull request #70 from hbgyeom1/master
 Fix, Update forestcox.R, forestglm.cox, additional buildcheck error
2 parents 03a5612 + 341ceba commit ed90290

7 files changed

Lines changed: 140 additions & 64 deletions

File tree

‎R/forestcox.R‎

Lines changed: 70 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -73,7 +73,13 @@ forestcoxUI <- function(id, label = "forestplot") {
7373
uiOutput(ns("cmp_eventtime")),
7474
checkboxInput(ns("custom_forest"), "Custom X axis ticks in forest plot"),
7575
uiOutput(ns("hr_points")),
76-
uiOutput(ns("numeric_inputs"))
76+
uiOutput(ns("numeric_inputs")),
77+
# Checkbox to decide line or diamond shape for Overall defult is ???
78+
checkboxInput(ns("summ"), "Toggle Overall Shape"),
79+
# Just like TT
80+
checkboxInput(ns("tt"), "Change Edge Shape"),
81+
# Checkbox for show/hide KM rate. Default is hide
82+
checkboxInput(ns("km"), "Show KM rate")
7783
)
7884
}
7985

@@ -163,7 +169,7 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
163169
moduleServer(
164170
id,
165171
function(input, output, session) {
166-
N <- V1 <- V2 <- .N <- HR <- Lower <- Upper <- level <- val_label <- variable <- NULL
172+
. <- N <- V1 <- V2 <- .N <- HR <- Lower <- Upper <- level <- val_label <- variable <- NULL
167173
fix_et <- !is.null(vec.event) && !is.null(vec.time) && (length(vec.event) == length(vec.time))
168174
if (is.null(data_varStruct)) {
169175
data_varStruct <- reactive(list(variable = names(data())))
@@ -324,12 +330,12 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
324330
)
325331
tagList(
326332
selectInput(session$ns("cmp_event_cox"), "Competing Event",
327-
choices = mklist(data_varStruct(), vlist()$factor_01vars), multiple = FALSE,
328-
selected = NULL
333+
choices = mklist(data_varStruct(), vlist()$factor_01vars), multiple = FALSE,
334+
selected = NULL
329335
),
330336
selectInput(session$ns("cmp_time_cox"), "Competing Time",
331-
choices = mklist(data_varStruct(), vlist()$conti_vars_positive), multiple = FALSE,
332-
selected = NULL
337+
choices = mklist(data_varStruct(), vlist()$conti_vars_positive), multiple = FALSE,
338+
selected = NULL
333339
)
334340
)
335341
})
@@ -467,7 +473,6 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
467473

468474
colnames(tbsub)[1:(2 + 2 * nrow(label[variable == group.tbsub]))] <- c("Subgroup", paste0("N(%): ", label[variable == group.tbsub, val_label]), paste0(var.time[2], "-", input$day, "\n", " KM rate(%): ", label[variable == group.tbsub, val_label]), "HR")
469475
}
470-
471476
return(tbsub)
472477
})
473478

@@ -489,37 +494,65 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
489494
figure <- reactive({
490495
group.tbsub <- input$group
491496
label <- data_label()
492-
data <- data.table::setDT(tbsub())
497+
# Changed how we copy data; this is safer
498+
data <- data.table::copy(tbsub())
493499
len <- ncol(data)
494500

495501
ll <- ifelse(group.tbsub %in% vlist()$group_vars, nrow(label[variable == group.tbsub]), 0)
496-
data[HR == 0 | Lower == 0, ":="(HR = NA, Lower = NA, Upper = NA)]
502+
# Copy rows to keep values for display
503+
data_for_display <- data[, .(HR, Lower, Upper)]
504+
# Now we can safely replace values for plotting
505+
data[HR == 0 | Lower == 0, ":="(HR = 0.001, Lower = min(data[Lower > 0, Lower]), Upper = 999)]
497506
data_est <- data$`HR`
498507
data[is.na(data)] <- " "
499-
data$HR <- ifelse(data$HR == " ", " ", paste0(data$HR, " (", data$Lower, "-", data$Upper, ")"))
508+
# Change row name selection to use copied row
509+
data$HR <- ifelse(data$HR == " ", " ", paste0(data_for_display$HR, " (", data_for_display$Lower, "-", data_for_display$Upper, ")"))
500510
data.table::setnames(data, "HR", "HR (95% CI)")
501511
data$` ` <- paste(rep(" ", 20), collapse = " ")
502-
tm <- forestploter::forest_theme(base_size = input$font, ci_Theight = 0.2)
503-
selected_columns <- c(c(1:(2 + 2 * ll)), len + 1, (len - 1):(len))
504-
xlim <- c(1 / input$xMax, input$xMax)
505-
xlim <- round(xlim[order(xlim)], 2)
506-
if (is.null(input$xMax) || any(is.na(xlim))) {
507-
xlim <- c(0, 2)
512+
# Just like TT
513+
if (isTRUE(input$tt)) {
514+
ci_Theight = FALSE
515+
} else {
516+
ci_Theight = 0.2
517+
}
518+
tm <- forestploter::forest_theme(base_size = input$font, ci_Theight = ci_Theight)
519+
# Now change row selection based on KM rate button
520+
if (isTRUE(input$km)) {
521+
selected_columns <- c(c(1:(2 + 2 * ll)), len + 1, (len - 1):(len))
522+
ci_column <- 3 + 2 * ll
523+
} else {
524+
selected_columns <- c(1:(1 + ll), 2 + 2*ll, len + 1, (len - 1):len)
525+
ci_column <- 3 + ll
526+
}
527+
# Determine Overall shape line vs diamond
528+
is_summary <- if (isTRUE(input$summ)) {
529+
rep(FALSE, nrow(data))
530+
} else {
531+
data$Subgroup == "Overall"
532+
}
533+
# Rectangle size
534+
if (is.null(input$rect) || is.na(input$rect)) {
535+
rect <- 0.5
536+
} else {
537+
rect <- input$rect
508538
}
509539
forestploter::forest(data[, .SD, .SDcols = selected_columns],
510-
lower = as.numeric(data$Lower),
511-
upper = as.numeric(data$Upper),
512-
ci_column = 3 + 2 * ll,
513-
est = as.numeric(data_est),
514-
ref_line = 1,
515-
ticks_digits = 1,
516-
x_trans = "log",
517-
xlim = NULL,
518-
arrow_lab = c(input$arrow_left, input$arrow_right),
519-
ticks_at = ticks(),
520-
theme = tm
540+
lower = as.numeric(data$Lower),
541+
upper = as.numeric(data$Upper),
542+
# Rectangle size
543+
sizes = rep(rect, nrow(data)),
544+
# Show summary which is the diamond shape here
545+
is_summary = is_summary,
546+
ci_column = ci_column,
547+
est = as.numeric(data_est),
548+
ref_line = 1,
549+
ticks_digits = 1,
550+
x_trans = "log",
551+
xlim = NULL,
552+
arrow_lab = c(input$arrow_left, input$arrow_right),
553+
ticks_at = ticks(),
554+
theme = tm
521555
) -> zz
522-
523556
l <- dim(zz)
524557
h <- zz$height[(l[1] - 2):(l[1] - 1)]
525558
zz <- print(zz[, 2:(l[2] - 1)], autofit = TRUE)
@@ -530,11 +563,11 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
530563
res <- reactive({
531564
list(
532565
datatable(tbsub(),
533-
caption = paste0(input$dep, " subgroup analysis"), rownames = F, extensions = "Buttons",
534-
options = c(
535-
opt.tb1(paste0("tbsub_", input$dep)),
536-
list(scrollX = TRUE, columnDefs = list(list(className = "dt-right", targets = 0)))
537-
)
566+
caption = paste0(input$dep, " subgroup analysis"), rownames = F, extensions = "Buttons",
567+
options = c(
568+
opt.tb1(paste0("tbsub_", input$dep)),
569+
list(scrollX = TRUE, columnDefs = list(list(className = "dt-right", targets = 0)))
570+
)
538571
),
539572
figure()
540573
)
@@ -543,6 +576,10 @@ forestcoxServer <- function(id, data, data_label, data_varStruct = NULL, nfactor
543576
output$downloadControls <- renderUI({
544577
tagList(
545578
fluidRow(
579+
column(
580+
3,
581+
numericInput(session$ns("rect"), "rectangle-size", value = 0.5, step = 0.1)
582+
),
546583
column(
547584
3,
548585
numericInput(session$ns("font"), "font-size", value = 12)

‎R/forestglm.R‎

Lines changed: 61 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,9 @@ forestglmUI <- function(id, label = "forestplot") {
6161
uiOutput(ns("cov_tbsub")),
6262
checkboxInput(ns("custom_forest"), "Custom X axis ticks in forest plot"),
6363
uiOutput(ns("beta_points")),
64-
uiOutput(ns("numeric_inputs"))
64+
uiOutput(ns("numeric_inputs")),
65+
checkboxInput(ns("summ"), "Toggle Overall Shape"),
66+
checkboxInput(ns("tt"), "Change Edge Shape")
6567
)
6668
}
6769

@@ -424,11 +426,11 @@ forestglmServer <- function(id, data, data_label, family, data_varStruct = NULL,
424426
res <- reactive({
425427
list(
426428
datatable(tbsub(),
427-
caption = paste0(input$dep, " subgroup analysis"), rownames = F, extensions = "Buttons",
428-
options = c(
429-
opt.tb1(paste0("tbsub_", input$dep)),
430-
list(scrollX = TRUE, columnDefs = list(list(className = "dt-right", targets = 0)))
431-
)
429+
caption = paste0(input$dep, " subgroup analysis"), rownames = F, extensions = "Buttons",
430+
options = c(
431+
opt.tb1(paste0("tbsub_", input$dep)),
432+
list(scrollX = TRUE, columnDefs = list(list(className = "dt-right", targets = 0)))
433+
)
432434
),
433435
figure()
434436
)
@@ -442,15 +444,19 @@ forestglmServer <- function(id, data, data_label, family, data_varStruct = NULL,
442444
uiOutput(session$ns("xlim_forest"))
443445
),
444446
column(
445-
3,
447+
2,
448+
numericInput(session$ns("rect"), "rectangle-size", value = 0.5, step = 0.1)
449+
),
450+
column(
451+
2,
446452
numericInput(session$ns("font"), "font-size", value = 12)
447453
),
448454
column(
449-
3,
455+
2,
450456
textInput(session$ns("arrow_left"), "arrow left", value = "Better")
451457
),
452458
column(
453-
3,
459+
2,
454460
textInput(session$ns("arrow_right"), "arrow right", value = "Worse")
455461
)
456462
),
@@ -467,7 +473,8 @@ forestglmServer <- function(id, data, data_label, family, data_varStruct = NULL,
467473
)
468474
})
469475
figure <- reactive({
470-
data <- data.table::setDT(tbsub())
476+
# Changed how we copy data; this is safer
477+
data <- data.table::copy(tbsub())
471478
group.tbsub <- input$group
472479
if (family != "binomial") {
473480
if (family == "gaussian") {
@@ -477,40 +484,69 @@ forestglmServer <- function(id, data, data_label, family, data_varStruct = NULL,
477484
}
478485

479486
ll <- 1
480-
data[Beta == 0 | Lower == 0, ":="(Beta = NA, Lower = NA, Upper = NA)]
487+
# Copy rows to keep values for display
488+
data_for_display <- data[, .(Beta, Lower, Upper)]
489+
# Now we can safely replace values for plotting
490+
data[Beta == 0 | Lower == 0, ":="(Beta = 0.001, Lower = min(data[Lower > 0, Lower]), Upper = 999)]
481491
} else {
482492
r <- "OR"
483493
ll <- nrow(data_label()[variable == group.tbsub])
484-
data[OR == 0 | Lower == 0, ":="(OR = NA, Lower = NA, Upper = NA)]
494+
# Copy rows to keep values for display 2
495+
data_for_display <- data[, .(OR, Lower, Upper)]
496+
# Now we can safely replace values for plotting 2
497+
data[OR == 0 | Lower == 0, ":="(OR = 0.001, Lower = min(data[Lower > 0, Lower]), Upper = 999)]
485498
}
486499

487500
len <- ncol(data)
488501
data_est <- data[, get(r)]
489502
data[is.na(data)] <- " "
490-
data[[r]] <- ifelse(data[[r]] == " ", " ", paste0(data[[r]], " (", data$Lower, "-", data$Upper, ")"))
503+
# Change row name selection to use copied row
504+
data[[r]] <- ifelse(data[[r]] == " ", " ", paste0(data_for_display[[r]], " (", data_for_display$Lower, "-", data_for_display$Upper, ")"))
491505
data$` ` <- paste(rep(" ", 20), collapse = " ")
506+
# Just like TT
507+
if (isTRUE(input$tt)) {
508+
ci_Theight = FALSE
509+
} else {
510+
ci_Theight = 0.2
511+
}
492512
tm <- forestploter::forest_theme(
493513
base_size = input$font,
494-
ci_Theight = 0.2
514+
ci_Theight = ci_Theight
495515
)
496516
xlim <- c(ifelse(family == "gaussian", (-1) * input$xMax, 1 / input$xMax), input$xMax)
497517
xlim <- round(xlim[order(xlim)], 2)
498518
if (is.null(input$xMax) || any(is.na(xlim))) {
499519
xlim <- c(0, 2)
500520
}
501521
selected_columns <- c(c(1:(2 + ll)), len + 1, (len - 1):(len))
522+
# Determine Overall shape line vs diamond
523+
is_summary <- if (isTRUE(input$summ)) {
524+
rep(FALSE, nrow(data))
525+
} else {
526+
data$Subgroup == "Overall"
527+
}
528+
# Rectangle size
529+
if (is.null(input$rect) || is.na(input$rect)) {
530+
rect <- 0.5
531+
} else {
532+
rect <- input$rect
533+
}
502534
forestploter::forest(data[, .SD, .SDcols = selected_columns],
503-
lower = as.numeric(data$Lower),
504-
upper = as.numeric(data$Upper),
505-
ci_column = 3 + ll,
506-
est = as.numeric(data_est),
507-
ref_line = ifelse(family == "gaussian", 0, 1),
508-
x_trans = ifelse(family == "gaussian", "none", "log"),
509-
ticks_digits = 1,
510-
xlim = NULL,
511-
ticks_at = ticks(),
512-
arrow_lab = c(input$arrow_left, input$arrow_right),
513-
theme = tm
535+
lower = as.numeric(data$Lower),
536+
upper = as.numeric(data$Upper),
537+
# Rectangle size
538+
sizes = rep(rect, nrow(data)),
539+
# Show summary which is the diamond shape here
540+
is_summary = is_summary,
541+
ci_column = 3 + ll,
542+
est = as.numeric(data_est),
543+
ref_line = ifelse(family == "gaussian", 0, 1),
544+
x_trans = ifelse(family == "gaussian", "none", "log"),
545+
ticks_digits = 1,
546+
xlim = NULL,
547+
ticks_at = ticks(),
548+
arrow_lab = c(input$arrow_left, input$arrow_right),
549+
theme = tm
514550
) -> zz
515551

516552
l <- dim(zz)

‎R/roc.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -901,7 +901,7 @@ rocModule <- function(input, output, session, data, data_label, data_varStruct =
901901

902902
rocModule2 <- function(input, output, session, data, data_label, data_varStruct = NULL, nfactor.limit = 10, design.survey = NULL, id.cluster = NULL) {
903903
## To remove NOTE.
904-
level <- variable <- NULL
904+
. <- level <- variable <- NULL
905905

906906
if (is.null(data_varStruct)) {
907907
data_varStruct <- reactive(list(variable = names(data())))

‎R/timeroc.R‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -58,7 +58,7 @@ timerocUI <- function(id) {
5858
uiOutput(ns("time")),
5959
checkboxInput(ns("subcheck"), "Sub-group analysis"),
6060
tags$p(
61-
strong("- Harrell’s C-index:"),
61+
strong("- Harrell's C-index:"),
6262
" calculated via ",
6363
code("survival::concordance()")
6464
),
@@ -629,7 +629,7 @@ timerocModule <- function(input, output, session, data, data_label,
629629

630630
indeps <- reactive(lapply(1:nmodel(), function(i) input[[paste0("indep_km", i)]]))
631631

632-
####################수정
632+
####################Fix
633633

634634
output$time <- renderUI({
635635
req(input$time_km)
@@ -696,7 +696,7 @@ timerocModule <- function(input, output, session, data, data_label,
696696

697697

698698
timerocList <- reactive({
699-
#########수정
699+
#########Fix
700700
req(input$event_km, input$time_km, input$time_to_roc)
701701
for (i in 1:nmodel()) {
702702
req(input[[paste0("indep_km", i)]])
@@ -998,7 +998,7 @@ timerocModule <- function(input, output, session, data, data_label,
998998

999999
timerocModule2 <- function(input, output, session, data, data_label, data_varStruct = NULL, nfactor.limit = 10, design.survey = NULL, id.cluster = NULL, iid = T, NRIIDI = T) {
10001000
## To remove NOTE.
1001-
ListModel <- compare <- level <- variable <- FP <- TP <- model <- Sensitivity <- Specificity <- NULL
1001+
. <- ListModel <- compare <- level <- variable <- FP <- TP <- model <- Sensitivity <- Specificity <- NULL
10021002

10031003
if (is.null(data_varStruct)) {
10041004
data_varStruct <- reactive(list(variable = names(data())))

‎man/rocModule.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/rocUI.Rd‎

Lines changed: 1 addition & 0 deletions
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/timerocModule.Rd‎

Lines changed: 2 additions & 1 deletion
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

0 commit comments

Comments
 (0)