Nothing
#' @title kaplanUI: shiny module UI for kaplan-meier plot
#' @description Shiny module UI for kaplan-meier plot
#' @param id id
#' @return Shiny module UI for kaplan-meier plot
#' @details Shiny module UI for kaplan-meier plot
#' @examples
#' library(shiny)
#' library(DT)
#' library(data.table)
#' library(jstable)
#' library(ggplot2)
#' ui <- fluidPage(
#' sidebarLayout(
#' sidebarPanel(
#' kaplanUI("kaplan")
#' ),
#' mainPanel(
#' plotOutput("kaplan_plot"),
#' ggplotdownUI("kaplan")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' data <- reactive(mtcars)
#' data.label <- reactive(jstable::mk.lev(mtcars))
#'
#' out_kaplan <- callModule(kaplanModule, "kaplan",
#' data = data, data_label = data.label,
#' data_varStruct = NULL
#' )
#'
#' output$kaplan_plot <- renderPlot({
#' print(out_kaplan())
#' })
#' }
#' @rdname kaplanUI
#' @export
kaplanUI <- function(id) {
# Create a namespace function using the provided id
ns <- NS(id)
tagList(
uiOutput(ns("eventtime")),
uiOutput(ns("indep")),
uiOutput(ns("cutconti")),
checkboxInput(ns("scale"), "% y scale", F),
checkboxInput(ns("cumhaz"), "Show cumulative incidence", F),
checkboxInput(ns("pval"), "Show p-value(log-rank test)", T),
checkboxInput(ns("table"), "Show table", T),
checkboxInput(ns("ci"), "Show 95% CI", F),
checkboxInput(ns("marks"), "Show censoring marks", F),
uiOutput(ns("ranges")),
checkboxInput(ns("landmark"), "Landmark analysis", F),
uiOutput(ns("val_landmark")),
checkboxInput(ns("showpercent"), "Show percent(%)", F),
checkboxInput(ns("subcheck"), "Sub-group analysis"),
uiOutput(ns("subvar")),
uiOutput(ns("subval"))
)
}
#' @title ggplotdownUI: Option & download module UI for ggplot
#' @description Option & download module UI for ggplot
#' @param id id
#' @return Option & download module UI for ggplot
#' @details Option & download module UI for ggplot
#' @examples
#' library(shiny)
#' library(DT)
#' library(data.table)
#' library(jstable)
#' library(ggplot2)
#' ui <- fluidPage(
#' sidebarLayout(
#' sidebarPanel(
#' kaplanUI("kaplan")
#' ),
#' mainPanel(
#' plotOutput("kaplan_plot"),
#' ggplotdownUI("kaplan")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' data <- reactive(mtcars)
#' data.label <- reactive(jstable::mk.lev(mtcars))
#'
#' out_kaplan <- callModule(kaplanModule, "kaplan",
#' data = data, data_label = data.label,
#' data_varStruct = NULL
#' )
#'
#' output$kaplan_plot <- renderPlot({
#' print(out_kaplan())
#' })
#' }
#' @rdname ggplotdownUI
#' @export
ggplotdownUI <- function(id) {
# Create a namespace function using the provided id
ns <- NS(id)
tagList(
h3("Download options"),
wellPanel(
uiOutput(ns("downloadControls")),
downloadButton(ns("downloadButton"), label = "Download the plot")
)
)
}
#' @title optionUI: Option UI with icon
#' @description Option UI with icon
#' @param id id
#' @return Option UI with icon
#' @details Option UI with icon
#' @examples
#' library(shiny)
#' library(DT)
#' library(data.table)
#' library(jstable)
#' library(ggplot2)
#' ui <- fluidPage(
#' sidebarLayout(
#' sidebarPanel(
#' kaplanUI("kaplan")
#' ),
#' mainPanel(
#' optionUI("kaplan"),
#' plotOutput("kaplan_plot"),
#' ggplotdownUI("kaplan")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' data <- reactive(mtcars)
#' data.label <- reactive(jstable::mk.lev(mtcars))
#'
#' out_kaplan <- callModule(kaplanModule, "kaplan",
#' data = data, data_label = data.label,
#' data_varStruct = NULL
#' )
#'
#' output$kaplan_plot <- renderPlot({
#' print(out_kaplan())
#' })
#' }
#' @seealso
#' \code{\link[shinyWidgets]{dropdownButton}},\code{\link[shinyWidgets]{tooltipOptions}}
#' @rdname optionUI
#' @export
#' @importFrom shinyWidgets dropdownButton tooltipOptions
optionUI <- function(id) {
# Create a namespace function using the provided id
ns <- NS(id)
shinyWidgets::dropdownButton(
uiOutput(ns("option_kaplan")),
circle = TRUE, status = "danger", icon = icon("gear"), width = "300px",
tooltip = shinyWidgets::tooltipOptions(title = "Click to see other options !")
)
}
#' @title kaplanModule: shiny module server for kaplan-meier plot.
#' @description Shiny module server for kaplan-meier plot.
#' @param input input
#' @param output output
#' @param session session
#' @param data Reactive data
#' @param data_label Reactive data label
#' @param data_varStruct Reactive List of variable structure, Default: NULL
#' @param nfactor.limit nlevels limit in factor variable, Default: 10
#' @param design.survey Reactive survey data. default: NULL
#' @param id.cluster Reactive cluster variable if marginal model, Default: NULL
#' @param timeby timeby, Default: NULL
#' @param range.x range of x axis, Default: NULL
#' @param range.y range of y axis, Default: NULL
#' @return Shiny module server for kaplan-meier plot.
#' @details Shiny module server for kaplan-meier plot.
#' @examples
#' library(shiny)
#' library(DT)
#' library(data.table)
#' library(jstable)
#' library(ggplot2)
#' ui <- fluidPage(
#' sidebarLayout(
#' sidebarPanel(
#' kaplanUI("kaplan")
#' ),
#' mainPanel(
#' plotOutput("kaplan_plot"),
#' ggplotdownUI("kaplan")
#' )
#' )
#' )
#'
#' server <- function(input, output, session) {
#' data <- reactive(mtcars)
#' data.label <- reactive(jstable::mk.lev(mtcars))
#'
#' out_kaplan <- callModule(kaplanModule, "kaplan",
#' data = data, data_label = data.label,
#' data_varStruct = NULL
#' )
#'
#' output$kaplan_plot <- renderPlot({
#' print(out_kaplan())
#' })
#' }
#' @rdname kaplanModule
#' @export
#' @import shiny
#' @importFrom data.table data.table .SD :=
#' @importFrom labelled var_label<-
#' @importFrom stats glm as.formula model.frame na.omit
#' @importFrom purrr map_lgl
#' @importFrom rvg dml
#' @importFrom officer read_pptx add_slide ph_with ph_location
#' @importFrom ggpubr as_ggplot
kaplanModule <- function(input, output, session, data, data_label, data_varStruct = NULL, nfactor.limit = 10, design.survey = NULL, id.cluster = NULL,
timeby = NULL, range.x = NULL, range.y = NULL) {
## To remove NOTE.
brewer.pal.info <- level <- val_label <- variable <- NULL
if (is.null(data_varStruct)) {
data_varStruct <- reactive(list(variable = names(data())))
}
vlist <- reactive({
mklist <- function(varlist, vars) {
lapply(
varlist,
function(x) {
inter <- intersect(x, vars)
if (length(inter) == 1) {
inter <- c(inter, "")
}
return(inter)
}
)
}
factor_vars <- names(data())[data()[, lapply(.SD, class) %in% c("factor", "character")]]
# factor_vars <- names(data())[sapply(names(data()), function(x){class(data()[[x]]) %in% c("factor", "character")})]
factor_list <- mklist(data_varStruct(), factor_vars)
conti_vars <- setdiff(names(data()), factor_vars)
if (!is.null(design.survey)) {
conti_vars <- setdiff(conti_vars, c(names(design.survey()$allprob), names(design.survey()$strata), names(design.survey()$cluster)))
}
conti_vars_positive <- conti_vars[unlist(data()[, lapply(.SD, function(x) {
min(x, na.rm = T) >= 0
}), .SDcols = conti_vars])]
conti_list <- mklist(data_varStruct(), conti_vars)
nclass_factor <- unlist(data()[, lapply(.SD, function(x) {
length(levels(x))
}), .SDcols = factor_vars])
# nclass_factor <- sapply(factor_vars, function(x){length(unique(data()[[x]]))})
class01_factor <- unlist(data()[, lapply(.SD, function(x) {
identical(levels(x), c("0", "1"))
}), .SDcols = factor_vars])
validate(
need(length(class01_factor) >= 1, "No categorical variables coded as 0, 1 in data")
)
factor_01vars <- factor_vars[class01_factor]
factor_01_list <- mklist(data_varStruct(), factor_01vars)
group_vars <- factor_vars[nclass_factor >= 2 & nclass_factor <= nfactor.limit & nclass_factor < nrow(data())]
group_list <- mklist(data_varStruct(), group_vars)
except_vars <- factor_vars[nclass_factor > nfactor.limit | nclass_factor == 1 | nclass_factor == nrow(data())]
return(list(
factor_vars = factor_vars, factor_list = factor_list, conti_vars = conti_vars, conti_list = conti_list, conti_vars_positive = conti_vars_positive,
factor_01vars = factor_01vars, factor_01_list = factor_01_list, group_vars = group_vars, group_list = group_list, except_vars = except_vars
))
})
output$eventtime <- renderUI({
validate(
need(length(vlist()$factor_01vars) >= 1, "No candidate event variables coded as 0, 1"),
need(length(vlist()$conti_vars_positive) >= 1, "No candidate time variables")
)
tagList(
selectInput(session$ns("event_km"), "Event",
choices = mklist(data_varStruct(), vlist()$factor_01vars), multiple = F,
selected = NULL
),
selectInput(session$ns("time_km"), "Time",
choices = mklist(data_varStruct(), vlist()$conti_vars_positive), multiple = F,
selected = NULL
)
)
})
output$indep <- renderUI({
req(!is.null(input$event_km))
req(!is.null(input$time_km))
mklist <- function(varlist, vars) {
lapply(
varlist,
function(x) {
inter <- intersect(x, vars)
if (length(inter) == 1) {
inter <- c(inter, "")
}
return(inter)
}
)
}
if (!is.null(design.survey)) {
indep.km <- setdiff(names(data()), c(vlist()$except_vars, input$event_km, input$time_km, names(design.survey()$allprob), names(design.survey()$strata), names(design.survey()$cluster)))
} else if (!is.null(id.cluster)) {
indep.km <- setdiff(names(data()), c(vlist()$except_vars, input$event_km, input$time_km, id.cluster()))
} else {
indep.km <- setdiff(names(data()), c(vlist()$except_vars, input$event_km, input$time_km))
}
tagList(
selectInput(session$ns("indep_km"), "Independent variables",
choices = c("None", mklist(data_varStruct(), indep.km)), multiple = F,
selected = "None"
)
)
})
observeEvent(input$indep_km, {
output$cutconti <- renderUI({
if (input$indep_km %in% c("None", vlist()$factor_vars)) {
return(NULL)
} else if (!is.null(design.survey) | !is.null(id.cluster)) {
req(!is.null(input$event_km))
req(!is.null(input$time_km))
vec.indep <- data()[[input$indep_km]][!is.na(data()[[input$indep_km]])]
tagList(
numericInput(session$ns("cut5"), "Cut-off", value = median(vec.indep), min = quantile(vec.indep, 0.05), max = quantile(vec.indep, 0.95))
)
} else {
req(!is.null(input$event_km))
req(!is.null(input$time_km))
data.km <- data()
data.km[[input$event_km]] <- as.numeric(as.vector(data.km[[input$event_km]]))
mstat <- maxstat::maxstat.test(as.formula(paste("survival::Surv(", input$time_km, ",", input$event_km, ") ~ ", input$indep_km, sep = "")), data = data.km, smethod = "LogRank", pmethod = "condMC", B = 999)
cut5 <- mstat$cuts[order(-mstat$stats)][1:5]
vec.indep <- data.km[[input$indep_km]][!is.na(data.km[[input$indep_km]])]
tagList(
numericInput(session$ns("cut5"), "Cut-off", value = cut5[1], min = min(cut5[1], quantile(vec.indep, 0.05)), max = max(cut5[1], quantile(vec.indep, 0.95)))
)
}
})
})
observeEvent(input$subcheck, {
output$subvar <- renderUI({
req(input$subcheck == T)
req(!is.null(input$time_km))
var_subgroup <- setdiff(names(data()), c(vlist()$except_vars, input$time_km, input$event_km, input$indep_km))
if (!is.null(id.cluster)) {
var_subgroup <- setdiff(names(data()), c(vlist()$except_vars, input$time_km, input$event_km, input$indep_km, id.cluster()))
} else if (!is.null(design.survey)) {
var_subgroup <- setdiff(names(data()), union(c(names(design.survey()$strata), names(design.survey()$cluster), names(design.survey()$allprob)), c(vlist()$except_vars, input$time_km, input$event_km, input$indep_km)))
}
var_subgroup_list <- mklist(data_varStruct(), var_subgroup)
validate(
need(length(var_subgroup) > 0, "No variables for sub-group analysis")
)
tagList(
selectInput(session$ns("subvar_km"), "Sub-group variables",
choices = var_subgroup_list, multiple = T,
selected = var_subgroup[1]
)
)
})
})
output$subval <- renderUI({
req(input$subcheck == T)
req(length(input$subvar_km) > 0)
outUI <- tagList()
for (v in seq_along(input$subvar_km)) {
if (input$subvar_km[[v]] %in% vlist()$factor_vars) {
outUI[[v]] <- selectInput(session$ns(paste0("subval_km", v)), paste0("Sub-group value: ", input$subvar_km[[v]]),
choices = data_label()[variable == input$subvar_km[[v]], level], multiple = T,
selected = data_label()[variable == input$subvar_km[[v]], level][1]
)
} else {
val <- stats::quantile(data()[[input$subvar_km[[v]]]], na.rm = T)
outUI[[v]] <- sliderInput(session$ns(paste0("subval_km", v)), paste0("Sub-group range: ", input$subvar_km[[v]]),
min = val[1], max = val[5],
value = c(val[2], val[4])
)
}
}
outUI
})
form.km <- reactive({
validate(
need(!is.null(input$indep_km), "Please select at least 1 independent variable."),
need(!is.null(input$time_km), "Please select at least 1 time variable.")
)
if (input$indep_km == "None") {
return(as.formula(paste("survival::Surv(", input$time_km, ",", input$event_km, ") ~ ", "1", sep = "")))
} else if (input$indep_km %in% vlist()$factor_vars) {
return(as.formula(paste("survival::Surv(", input$time_km, ",", input$event_km, ") ~ ", input$indep_km, sep = "")))
} else {
return(as.formula(paste("survival::Surv(", input$time_km, ",", input$event_km, ") ~ ", "xcat", sep = "")))
}
})
kmList <- reactive({
req(!is.null(input$event_km))
req(!is.null(input$time_km))
req(input$indep_km)
data.km <- data()
label.regress <- data_label()
data.km[[input$event_km]] <- as.numeric(as.vector(data.km[[input$event_km]]))
if (input$subcheck == T) {
validate(
need(length(input$subvar_km) > 0, "No variables for subsetting"),
need(all(sapply(1:length(input$subvar_km), function(x) {
length(input[[paste0("subval_km", x)]])
})), "No value for subsetting")
)
for (v in seq_along(input$subvar_km)) {
if (input$subvar_km[[v]] %in% vlist()$factor_vars) {
data.km <- data.km[get(input$subvar_km[[v]]) %in% input[[paste0("subval_km", v)]]]
} else {
data.km <- data.km[get(input$subvar_km[[v]]) >= input[[paste0("subval_km", v)]][1] & get(input$subvar_km[[v]]) <= input[[paste0("subval_km", v)]][2]]
}
}
data.km[, (vlist()$factor_vars) := lapply(.SD, factor), .SDcols = vlist()$factor_vars]
label.regress2 <- mk.lev(data.km)[, c("variable", "level")]
data.table::setkey(data_label(), "variable", "level")
data.table::setkey(label.regress2, "variable", "level")
label.regress <- data_label()[label.regress2]
data.km[[input$event_km]] <- as.numeric(as.vector(data.km[[input$event_km]]))
}
if (input$indep_km %in% vlist()$conti_vars) {
data.km$xcat <- ifelse(data.km[[input$indep_km]] > input$cut5, 1, 0)
}
mf <- model.frame(form.km(), data.km)
validate(
need(nrow(mf) > 0, paste("No complete data due to missingness."))
)
if (is.null(design.survey)) {
cc <- substitute(survival::survfit(.form, data = data.km), list(.form = form.km()))
res.km <- eval(cc)
if (input$indep_km == "None") {
yst.name <- ""
yst.lab <- "All"
} else if (input$indep_km %in% vlist()$factor_vars) {
yst.name <- label.regress[variable == input$indep_km, var_label][1]
yst.lab <- label.regress[variable == input$indep_km, val_label]
} else {
yst.name <- paste(label.regress[variable == input$indep_km, var_label], "group")
yst.lab <- paste(label.regress[variable == input$indep_km, var_label], paste(c("\u2264", ">"), input$cut5, sep = ""))
}
ylab <- ifelse(input$cumhaz, "Cumulative incidence", "Survival")
return(list(res = res.km, ylab = ylab, yst.name = yst.name, yst.lab = yst.lab, data = data.km))
} else {
data.design <- design.survey()
label.regress <- data_label()
data.design$variables[[input$event_km]] <- as.numeric(as.vector(data.design$variables[[input$event_km]]))
if (input$subcheck == T) {
validate(
need(length(input$subvar_km) > 0, "No variables for subsetting"),
need(all(sapply(1:length(input$subvar_km), function(x) {
length(input[[paste0("subval_km", x)]])
})), "No value for subsetting")
)
for (v in seq_along(input$subvar_km)) {
if (input$subvar_km[[v]] %in% vlist()$factor_vars) {
data.design <- subset(data.design, get(input$subvar_km[[v]]) %in% input[[paste0("subval_km", v)]])
} else {
data.design <- subset(data.design, get(input$subvar_km[[v]]) >= input[[paste0("subval_km", v)]][1] & get(input$subvar_km[[v]]) <= input[[paste0("subval_km", v)]][2])
}
}
data.design$variables[, (vlist()$factor_vars) := lapply(.SD, factor), .SDcols = vlist()$factor_vars]
label.regress2 <- mk.lev(data.design$variables)[, c("variable", "class", "level")]
data.table::setkey(data_label(), "variable", "class", "level")
data.table::setkey(label.regress2, "variable", "class", "level")
label.regress <- data_label()[label.regress2]
data.design$variables[[input$event_km]] <- as.numeric(as.vector(data.design$variables[[input$event_km]]))
}
if (input$indep_km %in% vlist()$conti_vars) {
data.design$variables$xcat <- ifelse(data.design$variables[[input$indep_km]] > input$cut5, 1, 0)
}
cc <- substitute(survey::svykm(.form, design = data.design, se = input$ci), list(.form = form.km()))
res.km <- eval(cc)
if (input$indep_km == "None") {
yst.name <- ""
yst.lab <- "All"
} else if (input$indep_km %in% vlist()$factor_vars) {
yst.name <- label.regress[variable == input$indep_km, var_label][1]
yst.lab <- label.regress[variable == input$indep_km, val_label]
} else {
yst.name <- paste(label.regress[variable == input$indep_km, var_label], "group")
yst.lab <- paste(label.regress[variable == input$indep_km, var_label], paste(c(">", "\u2264"), input$cut5, sep = ""))
}
ylab <- ifelse(input$cumhaz, "Cumulative incidence", "Survival")
return(list(res = res.km, ylab = ylab, yst.name = yst.name, yst.lab = yst.lab, data = data.design))
}
})
observeEvent(kmList(), {
output$ranges <- renderUI({
res.km <- kmList()$res
if (is.null(design.survey)) {
xmax <- max(res.km$time)
} else {
if (is(res.km, "svykmlist")) {
xmax <- max(sapply(res.km, function(x) {
max(x$time)
}))
} else if (is(res.km, "svykm")) {
xmax <- max(res.km$time)
}
}
value.timeby <- signif(xmax / 7, 1)
if (!is.null(timeby)) {
value.timeby <- timeby
}
if (is.null(range.x)) {
range.x <- c(0, xmax)
}
if (is.null(range.y)) {
range.y <- c(0, 1)
}
xstep.default <- ifelse(xmax <= 365, 0.5, 5)
tagList(
sliderInput(session$ns("timeby"), "Time by",
min = 0, max = xmax, value = value.timeby, step = xstep.default
),
sliderInput(session$ns("xlims"), "X axis range(time)",
min = 0, max = xmax, value = range.x, step = xstep.default
),
sliderInput(session$ns("ylims"), "Y axis range(probability)",
min = 0, max = 1, value = range.y, step = 0.05
)
)
})
output$val_landmark <- renderUI({
if (input$landmark) {
sliderInput(session$ns("cut_landmark"), "Time cut-off for landmark analysis", min = input$xlims[1], max = input$xlims[2], value = input$timeby)
}
})
})
kmInput <- reactive({
req(kmList())
req(input$timeby >= 1)
req(input$xlims)
req(input$ylims)
res.km <- kmList()$res
ylab <- kmList()$ylab
yst.name <- kmList()$yst.name
yst.lab <- kmList()$yst.lab
data.km <- kmList()$data
if (is.null(input$legendx)) {
legend.p <- c(0.85, 0.8)
} else {
legend.p <- c(input$legendx, input$legendy)
}
if (is.null(input$pvalx)) {
pval.coord <- c(as.integer(input$xlims[1] + input$xlims[2] / 5), 0.1 + input$ylims[1])
} else {
pval.coord <- c(input$pvalx, input$pvaly)
}
pal <- ifelse(is.null(input$pal_km), "Set1", input$pal_km)
text.x <- ifelse(is.null(input$xaxis_km), "Time-to-event", input$xaxis_km)
dashed <- ifelse(is.null(input$linetype), F, input$linetype)
cut.landmark <- input$cut_landmark
if (input$landmark == F) {
cut.landmark <- NULL
}
surv.scale <- "default"
if (input$scale == T) {
surv.scale <- "percent"
}
if (is.null(design.survey)) {
if (is.null(id.cluster)) {
return(
jskm::jskm(res.km,
pval = input$pval, marks = input$marks, table = input$table, ylab = ylab, ystrataname = yst.name, ystratalabs = yst.lab, ci = input$ci, timeby = input$timeby, xlims = input$xlims, ylims = input$ylims,
cumhaz = input$cumhaz, cluster.option = "None", cluster.var = NULL, data = data.km, pval.coord = pval.coord, legendposition = legend.p, linecols = pal, xlabs = text.x, dashed = dashed, cut.landmark = cut.landmark,
showpercent = input$showpercent, surv.scale = surv.scale
)
)
} else {
return(
jskm::jskm(res.km,
pval = input$pval, marks = input$marks, table = input$table, ylab = ylab, ystrataname = yst.name, ystratalabs = yst.lab, ci = input$ci, timeby = input$timeby, xlims = input$xlims, ylims = input$ylims,
cumhaz = input$cumhaz, cluster.option = "cluster", cluster.var = id.cluster(), data = data.km, pval.coord = pval.coord, legendposition = legend.p, linecols = pal, xlabs = text.x, dashed = dashed, cut.landmark = cut.landmark,
showpercent = input$showpercent, surv.scale = surv.scale
)
)
}
} else {
return(
jskm::svyjskm(res.km,
pval = input$pval, table = input$table, ylab = ylab, ystrataname = yst.name, ystratalabs = yst.lab, ci = input$ci, timeby = input$timeby, xlims = input$xlims, ylims = input$ylims,
cumhaz = input$cumhaz, design = data.km, pval.coord = pval.coord, legendposition = legend.p, linecols = pal, xlabs = text.x, dashed = dashed, cut.landmark = cut.landmark,
showpercent = input$showpercent, surv.scale = surv.scale
)
)
}
})
output$downloadControls <- renderUI({
tagList(
column(
4,
selectizeInput(session$ns("file_ext"), "File extension (dpi = 300)",
choices = c("jpg", "pdf", "tiff", "svg", "pptx"), multiple = F,
selected = "pptx"
)
),
column(
4,
sliderInput(session$ns("fig_width"), "Width (in):",
min = 5, max = 15, value = 8
)
),
column(
4,
sliderInput(session$ns("fig_height"), "Height (in):",
min = 5, max = 15, value = 6
)
)
)
})
output$downloadButton <- downloadHandler(
filename = function() {
if (is.null(design.survey)) {
if (is.null(id.cluster)) {
return(paste(input$event_km, "_", input$indep_km, "_kaplan_meier.", input$file_ext, sep = ""))
} else {
return(paste(input$event_km, "_", input$indep_km, "_kaplan_meier_marginal.", input$file_ext, sep = ""))
}
} else {
return(paste(input$event_km, "_", input$indep_km, "_surveykaplan_meier.", input$file_ext, sep = ""))
}
},
# content is a function with argument file. content writes the plot to the device
content = function(file) {
withProgress(
message = "Download in progress",
detail = "This may take a while...",
value = 0,
{
for (i in 1:15) {
incProgress(1 / 15)
Sys.sleep(0.01)
}
if (input$file_ext == "pptx") {
my_vec_graph <- rvg::dml(ggobj = kmInput())
doc <- officer::read_pptx()
doc <- officer::add_slide(doc, layout = "Title and Content", master = "Office Theme")
doc <- officer::ph_with(doc, my_vec_graph, location = officer::ph_location(width = input$fig_width, height = input$fig_height))
print(doc, target = file)
} else {
ggsave(file, kmInput(), dpi = 300, units = "in", width = input$fig_width, height = input$fig_height)
}
}
)
}
)
output$option_kaplan <- renderUI({
if (input$indep_km == "None") {
tagList(
h3("Legend position"),
sliderInput(session$ns("legendx"), "x-axis (proportion)",
min = 0, max = 1, value = 0.85
),
sliderInput(session$ns("legendy"), "y-axis",
min = 0, max = 1, value = 0.8
),
textInput(session$ns("xaxis_km"), "x-axis text", "Time-to-event"),
radioButtons(session$ns("pal_km"), "Line color", choices = rownames(RColorBrewer::brewer.pal.info), selected = "Set1", inline = T)
)
} else {
tagList(
h3("Legend position"),
sliderInput(session$ns("legendx"), "x-axis (proportion)",
min = 0, max = 1, value = 0.85
),
sliderInput(session$ns("legendy"), "y-axis",
min = 0, max = 1, value = 0.8
),
h3("P-value position"),
sliderInput(session$ns("pvalx"), "x-axis (time)",
min = 0, max = input$xlims[2], value = as.integer(input$xlims[1] + input$xlims[2] / 5)
),
sliderInput(session$ns("pvaly"), "y-axis",
min = 0, max = 1, value = 0.1 + input$ylims[1]
),
h3("Line"),
radioButtons(session$ns("pal_km"), "Line color", choices = c("black", rownames(RColorBrewer::brewer.pal.info)), selected = "Set1", inline = T),
checkboxInput(session$ns("linetype"), "Different line type", value = F),
h3("Others"),
textInput(session$ns("xaxis_km"), "x-axis text", "Time-to-event")
)
}
})
return(kmInput)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.