inst/shiny-examples/scdhlm/server.R
In jepusto/scdhlm: Estimating Hierarchical Linear Models for Single-Case Designs
library(shiny)
library(markdown)
library(ggplot2)
library(scdhlm)
library(readxl)
library(janitor)
source("mappings.R", local = TRUE)
source("helper-functions.R", local = TRUE)
source("lme-fit.R", local = TRUE)
server <-
shinyServer(function(input, output, session) {
if (exists("dataset", where = environment(server))) if (!is.null(dataset)) {
updateRadioButtons(
session,
inputId = 'dat_type',
label = 'What data do you want to use?',
choices = c("Use an example" = "example",
"Upload data from a .csv or .txt file" = "dat",
"Upload data from a .xlsx file" = "xlsx",
"Use the dataset specified at initialization" = "loaded"),
selected = "loaded"
)
}
sheetname <- reactive({
if (input$dat_type == "xlsx") {
inFile <- input$xlsx
if (is.null(inFile)) return(NULL)
sheetnames <- excel_sheets(inFile$datapath)
}
})
observe({
sheets <- sheetname()
updateSelectInput(session, "inSelect", label = "Select a sheet",
choices = sheets,
selected = sheets[1])
})
# Read in data
datFile <- reactive({
if (input$dat_type == "dat") {
inFile <- input$dat
if (is.null(inFile)) return(NULL)
read.table(inFile$datapath, header=input$header,
sep=input$sep, quote=input$quote,
stringsAsFactors = FALSE) %>%
clean_names(case = "parsed")
} else if (input$dat_type == "xlsx") {
inFile <- input$xlsx
if (is.null(inFile) || is.null(input$inSelect) || nchar(input$inSelect) == 0) return(NULL)
readxl::read_xlsx(inFile$datapath, col_names = input$col_names,
sheet = input$inSelect) %>%
clean_names(case = "parsed") %>%
as.data.frame()
} else if (input$dat_type == "loaded") {
dataset %>%
clean_names(case = "parsed")
}
})
# Check that file is uploaded
output$fileUploaded <- reactive({
return(!is.null(datFile()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
# Study design with defaults
studyDesign <- reactive({
if (input$dat_type == "example") {
exampleMapping[[input$example]]$design
} else {
input$design
}
})
# Variable mapping interface
output$variableMapping <- renderUI({
var_names <- names(datFile())
n_var <- length(var_names)
if (studyDesign() %in% c("MBP", "TR")) {
list(
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
} else if (studyDesign() == "RMBB") {
list(
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 4]),
selectInput("seriesID", label = "Series identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
} else if (studyDesign() == "CMB") {
list(
selectInput("clusterID", label = "Cluster identifier", choices = var_names, selected = var_names[n_var - 4]),
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
}
})
variablesLoaded <- reactive({
if (is.null(input$caseID) | is.null(input$phaseID) | is.null(input$session) | is.null(input$outcome)) {
FALSE
} else {
(nchar(input$caseID) > 0) & (nchar(input$phaseID) > 0) & (nchar(input$session) > 0) & (nchar(input$outcome) > 0)
}
})
# Check Session variable
output$sessionIssues1 <- renderUI({
if (!variablesLoaded()) return(NULL)
sessions <- datFile()[,input$session]
if (!is.numeric(sessions) && !is.integer(sessions)) {
list(
strong(style="color:red", "Session variable contains non-numeric data."),
br("")
)
} else if (!isTRUE(all.equal(sessions, round(sessions)))) {
checkboxInput('round_session', 'Round Session variable to nearest integer?', TRUE)
}
})
output$sessionIssues2 <- renderUI({
if (!variablesLoaded()) return(NULL)
sessions <- datFile()[,input$session]
case_var <- datFile()[,input$caseID,drop=FALSE]
filter_vars <- datFile()[,input$filters,drop=FALSE]
split_vars <- cbind(case_var, filter_vars)
if (studyDesign() == "RMBB") {
series_var <- datFile()[, input$seriesID, drop=FALSE]
split_vars <- cbind(case_var, series_var, filter_vars)
} else if (studyDesign() == "CMB") {
cluster_var <- datFile()[, input$clusterID, drop=FALSE]
split_vars <- cbind(cluster_var, case_var, filter_vars)
}
if (length(split_vars) > 0 & is.numeric(sessions)) {
if (!is.null(input$round_session)) if (input$round_session) sessions <- round(sessions)
unique_sessions <- tapply(sessions, split_vars,
function(x) isTRUE(all.equal(x, unique(x))))
if (!all(unique_sessions, na.rm = TRUE)) {
list(
strong(style="color:red", "Session variable contains repeated values. Please ensure that each data point has a unique value within each case."),
br("")
)
}
}
})
output$outcomeMapping <- renderUI({
var_names <- names(datFile())
n_var <- length(var_names)
selectInput("outcome", label = "Outcome variable", choices = var_names, selected = var_names[n_var])
})
# Check Outcome variable
output$outcomeIssue <- renderUI({
if (!variablesLoaded()) return(NULL)
outcomes <- datFile()[,input$outcome]
if (!is.numeric(outcomes) && !is.integer(outcomes)) {
list(
strong(style="color:red", "Outcome variable contains non-numeric data. Please use a numeric outcome variable."),
br("")
)
}
})
# Treatment label mapping interface
output$phaseMapping <- renderUI({
if (!variablesLoaded()) return(NULL)
phases <- levels(as.factor(datFile()[,input$phaseID]))
list(
selectInput("baseline", label = "Baseline level", choices = phases, selected = phases[1]),
selectInput("treatment", label = "Treatment level", choices = phases, selected = phases[2])
)
})
# Filtering interface
output$filtervarMapping <- renderUI({
if (input$dat_type == "example") {
} else {
var_names <- names(datFile())
n_var <- length(var_names)
list(
selectizeInput("filters", label = "Filtering variables", choices = var_names, selected = NULL, multiple = TRUE)
)
}
})
output$filterMapping <- renderUI({
if (input$dat_type == "example") {
if (is.null(input$example)) return(NULL)
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
filter_vals <- lapply(filter_vars, function(x) example_parms[[paste0("filter_", x)]])
names(filter_vals) <- filter_vars
header <- strong("Please select the variables you wish to filter.")
} else {
filter_vars <- input$filters
filter_vals <- lapply(filter_vars, function(x) levels(as.factor(datFile()[,x])))
names(filter_vals) <- filter_vars
header <- strong("Values for the filtering variables.")
}
filter_selects <- lapply(filter_vars, function(x)
selectizeInput(paste0("filter_",x), label = x, choices = filter_vals[[x]],
selected = filter_vals[[x]][1], multiple = TRUE))
if (length(filter_vars) > 0) {
filter_selects <- list(header, column(12, br()), filter_selects)
}
filter_selects
})
# Clean the data
datClean <- reactive({
if (input$dat_type == "example") {
data(list = input$example)
dat <- get(input$example)
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
if (!is.null(filter_vars)) {
subset_vals <- sapply(filter_vars, function(x) levels(dat[[x]])[dat[[x]]] %in% input[[paste0("filter_",x)]])
dat <- dat[apply(subset_vals, 1, all),]
}
dat <- dat[,example_parms$vars]
if (studyDesign() %in% c("MBP", "TR")) {
names(dat) <- c("case","session","phase","outcome")
cluster <- series <- NULL
} else if (studyDesign() == "RMBB"){
names(dat) <- c("studyID","case", "series", "outcome", "session", "phase", "trt_time", "time_c")
cluster <- NULL
} else if (studyDesign() == "CMB") {
names(dat) <- c("studyID","school", "cluster", "case", "phase", "session", "session_trt", "outcome", "session_c")
series <- NULL
}
dat <- preprocess_SCD(design = studyDesign(),
cluster = cluster,
case = case, series = series,
phase = phase,
session = session, outcome = outcome,
data = dat)
} else {
case <- datFile()[,input$caseID]
phase <- datFile()[,input$phaseID]
session <- as.numeric(datFile()[,input$session])
outcome <- as.numeric(datFile()[,input$outcome])
cluster <- series <- NULL
dat <- data.frame(case = case, phase = phase, session = session, outcome = outcome)
if (studyDesign() == "RMBB") {
dat$series <- datFile()[,input$seriesID]
dat <- dat[order(dat$case, dat$series, dat$session),]
} else if (studyDesign() == "CMB") {
dat$cluster <- datFile()[,input$clusterID]
dat <- dat[order(dat$cluster, dat$case, dat$session),]
} else {
dat <- dat[order(dat$case, dat$session),]
}
if (!is.null(input$filters)) {
subset_vals <- sapply(input$filters, function(x) datFile()[[x]] %in% input[[paste0("filter_",x)]])
dat <- dat[apply(subset_vals, 1, all),]
}
design <- studyDesign()
round_session <- if (!is.null(input$round_session)) TRUE else FALSE
treatment_name <- input$treatment
dat <- preprocess_SCD(design = design,
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
round_session = round_session, treatment_name = treatment_name,
data = dat)
}
# if (studyDesign() == "MBP") {
# names(dat)[6] <- "session_trt"
# } else if (studyDesign() == "TR") {
# names(dat)[6] <- "phase_pair"
# } else if (studyDesign() %in% c("RMBB", "CMB")) {
# names(dat)[7] <- "session_trt"
# }
return(dat)
})
output$datTable <- renderTable(datClean())
# Estimation method
output$estMethod <- renderUI({
estimation_choices <- if (studyDesign() %in% c("MBP", "TR")) {
estimation_names
} else {
c("Restricted Maximum Likelihood" = "RML")
}
selectInput("method", label = "Estimation method",
choices = estimation_choices,
selected = "RML")
})
# Centering and timing sliders for RML estimation of MBD
time_range <- reactive({
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
default_times(
design = studyDesign(),
case = case, phase = phase, session = session,
cluster = cluster, series = series,
treatment_name = NULL, data = datClean()
)
})
output$model_centering <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML") {
session_range <- time_range()$range
sliderInput("model_center", "Center session at",
min=session_range[1], max=session_range[2],
value=time_range()$B, step = 1)
}
})
output$ES_timing_message <- renderText({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML" &
any(input$degree_trt != 0, (input$degree_base != 0 & input$RE_base > 0))) {
note_txt <- "Note: Options for selecting an initial treatment time and follow-up time can be modified on the next page."
HTML(note_txt)
}
})
output$ES_timing <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML" &
any(input$degree_trt != 0, (input$degree_base != 0 & input$RE_base > 0))) {
timings <- time_range()
wellPanel(
fluidRow(
column(12,
h4("Hypothetical experimental parameters")
),
column(6,
sliderInput("A_time", "Initial treatment time",
min = timings$range[1], max = timings$range[2],
value = timings$A, step = 1)
),
column(6,
sliderInput("B_time", "Follow-up time",
min = timings$range[1], max = timings$range[2],
value = timings$B, step = 1)
)
)
)
}
})
# Model degree
output$modelDegree_baseline <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
selectInput("degree_base", label = "Type of time trend", choices = time_trends_baseline, width = "40%")
}
})
output$modelDegree_treatment <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
selectInput("degree_trt", label = "Type of time trend", choices = time_trends_treatment, width = "40%")
}
})
# Model specification
output$modelSpec_baseline <- renderUI({
deg_base <- if (is.null(input$degree_base)) 0 else as.numeric(input$degree_base)
degree_base_list <- 0:deg_base
names(degree_base_list) <- degree_names_baseline[1:(deg_base + 1)]
if (studyDesign() %in% c("MBP", "TR")) {
fluidRow(
column(6,
checkboxGroupInput("FE_base", labs_MBP$fixed, degree_base_list, selected = degree_base_list)
),
column(6,
checkboxGroupInput("RE_base", labs_MBP$random, degree_base_list, selected = 0)
)
)
} else if (studyDesign() == "RMBB") {
fluidRow(
column(4,
checkboxGroupInput("FE_base", labs_RMBB$fixed, degree_base_list, selected = degree_base_list)
),
column(4,
checkboxGroupInput("RE_base", labs_RMBB$random_series, degree_base_list, selected = 0)
),
column(4,
checkboxGroupInput("RE_base2", labs_RMBB$random_case, degree_base_list, selected = 0)
)
)
} else if (studyDesign() == "CMB") {
fluidRow(
column(4,
checkboxGroupInput("FE_base", labs_CMB$fixed, degree_base_list, selected = degree_base_list)
),
column(4,
checkboxGroupInput("RE_base", labs_CMB$random_case, degree_base_list, selected = 0)
),
column(4,
checkboxGroupInput("RE_base2", labs_CMB$random_cluster, degree_base_list, selected = 0)
)
)
}
})
output$modelSpec_treatment <- renderUI({
deg_trt <- if (is.null(input$degree_trt)) 0 else as.numeric(input$degree_trt)
degree_trt_list <- 0:deg_trt
names(degree_trt_list) <- degree_names_treatment[1:(deg_trt + 1)]
if (studyDesign() %in% c("MBP", "TR")) {
fluidRow(
column(6,
checkboxGroupInput("FE_trt", labs_MBP$fixed, degree_trt_list, selected = degree_trt_list)
),
column(6,
checkboxGroupInput("RE_trt", labs_MBP$random, degree_trt_list, selected = NULL)
)
)
} else if (studyDesign() == "RMBB") {
fluidRow(
column(4,
checkboxGroupInput("FE_trt", labs_RMBB$fixed, degree_trt_list, selected = degree_trt_list)
),
column(4,
checkboxGroupInput("RE_trt", labs_RMBB$random_series, degree_trt_list, selected = NULL)
),
column(4,
checkboxGroupInput("RE_trt2", labs_RMBB$random_case, degree_trt_list, selected = NULL)
)
)
} else if (studyDesign() == "CMB") {
fluidRow(
column(4,
checkboxGroupInput("FE_trt", labs_CMB$fixed, degree_trt_list, selected = degree_trt_list)
),
column(4,
checkboxGroupInput("RE_trt", labs_CMB$random_case, degree_trt_list, selected = NULL)
),
column(4,
checkboxGroupInput("RE_trt2", labs_CMB$random_cluster, degree_trt_list, selected = NULL)
)
)
}
})
# Validate model specification
model_validation <- reactive({
if (studyDesign() %in% c("MBP", "TR")) {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$case),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt)
} else if (studyDesign() == "RMBB") {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$case),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt,
RE_base2 = input$RE_base2, RE_trt2 = input$RE_trt2)
} else {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$cluster),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt,
RE_base2 = input$RE_base2, RE_trt2 = input$RE_trt2)
}
})
output$model_spec <- renderUI({model_validation()})
# Fit model
model_fit <- reactive({
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
fit_function <- switch(studyDesign(),
MBP = "lme_fit_MB",
RMBB = "lme_fit_MB",
CMB = "lme_fit_MB",
TR = "lme_fit_TR")
if (studyDesign() %in% c("MBP", "TR")) {
RE_base2 <- RE_trt2 <- NULL
} else {
RE_base2 <- input$RE_base2
RE_trt2 <- input$RE_trt2
}
do.call(fit_function,
args = list(design = studyDesign(), dat = datClean(),
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
varStruct = input$varStruct,
corStruct = input$corStruct,
center = center))
})
# Model spec output
output$model_sample_size <- renderTable({
if (input$method == "RML") {
if (studyDesign() %in% c("MBP", "TR")) {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of groups" = nlevels(summary(model_fit()$fit)$groups$case),
check.names = FALSE)
} else if (studyDesign() == "CMB") {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of cases" = nlevels(summary(model_fit()$fit)$groups$case),
"Total number of clusters" = nlevels(summary(model_fit()$fit)$groups$cluster),
check.names = FALSE)
} else if (studyDesign() == "RMBB") {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of series" = nlevels(summary(model_fit()$fit)$groups$series),
"Total number of cases" = nlevels(summary(model_fit()$fit)$groups$case),
check.names = FALSE)
}
}
},
caption = "Sample sizes",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_fixed <- renderTable({
if (input$method == "RML") {
summary(model_fit()$fit)$tTable
}
},
caption = "Fixed effects",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = TRUE)
output$model_fit_random <- renderTable({
if (input$method == "RML") {
random_table <- data.frame(VarCorr(model_fit()$fit)[])
rownames <- rownames(VarCorr(model_fit()$fit)[])
# set the rownames
if (studyDesign() %in% c("CMB", "RMBB")) {
row_index_lvl3 <- length(input$RE_base2)+length(input$RE_trt2)+1
rownames_lvl3 <- c("", rownames[2:row_index_lvl3])
rownames_lvl2 <- c("", rownames[(row_index_lvl3 + 2):(length(rownames))])
name_lvl3 <- if (studyDesign() == "CMB") "<strong>Cluster-level</strong>" else "<strong>Case-level</strong>"
name_lvl2 <- if (studyDesign() == "CMB") "<strong>Case-level</strong>" else "<strong>Series-level</strong>"
random_levels <- c(name_lvl3, rep("", row_index_lvl3-1), name_lvl2, rep("", (length(rownames)-row_index_lvl3-1)))
random_table[1, 1] <- NA # get rid of pdLogChol
random_table[(row_index_lvl3 + 1), 1] <- NA
random_table <- cbind("Level" = random_levels, "Rowname" = c(rownames_lvl3, rownames_lvl2), random_table)
random_table[, 3:4] <- lapply(random_table[, 3:4], function(x) as.numeric(x))
names(random_table)[2] <- ""
} else if (studyDesign() %in% c("MBP", "TR")) {
random_table <- cbind("Rowname" = rownames, random_table)
random_table[, 2:3] <- lapply(random_table[, 2:3], function(x) as.numeric(x))
names(random_table)[1] <- ""
}
# set the column names
columnnames <- names(random_table)
names(random_table) <- gsub("V[0-9]|Var.[0-9]", "", columnnames)
random_table
}
},
caption = "Random effects",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, na = "", include.rownames = FALSE, sanitize.text.function = function(x){x})
output$model_fit_corr <- renderTable({
if (input$method=="RML" & input$corStruct != "IID") {
data.frame(
"Correlation parameter" = effect_size()$`Auto-correlation`,
check.names = FALSE
)
}
},
caption = "Correlation structure",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_var <- renderTable({
if (input$method == "RML" & input$varStruct == "het") {
data.frame(
"Baseline" = 1,
"Treatment" = effect_size()$`Variance parameter`
)
}
},
caption = "Variance structure",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_info <- renderTable({
if (input$method == "RML") {
data.frame("AIC" = AIC(model_fit()$fit),
"BIC" = BIC(model_fit()$fit),
"Log likelihood" = as.numeric(model_fit()$fit$logLik),
check.names = FALSE)
}
},
caption = "Information criteria",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_convg <- renderTable({
if (input$method=="RML") {
if (isTRUE(model_fit()$converged)) {
"The model converged."
} else {
"The model did not converge."
}
}
}, colnames = FALSE)
# Calculate effect sizes
effect_size <- reactive({
if ("lme" %in% class(model_fit()$fit)) {
if (studyDesign() %in% c("MBP", "TR")) {
RE_base2 <- RE_trt2 <- NULL
} else {
RE_base2 <- input$RE_base2
RE_trt2 <- input$RE_trt2
}
if (input$method=="RML") {
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
A <- if (is.null(input$A_time)) 0L else input$A_time
B <- if (is.null(input$B_time)) 1L else input$B_time
res <- effect_size_RML(design = studyDesign(), dat = datClean(),
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
varStruct = input$varStruct,
corStruct = input$corStruct,
A = A, B = B, center = center)
} else {
if (studyDesign()=="MBP") {
res <- with(datClean(), effect_size_MB(outcome = outcome, treatment = trt, id = case, time = session))
} else if (studyDesign()=="TR") {
res <- with(datClean(), effect_size_ABk(outcome = outcome, treatment = trt, id = case, phase = phase_pair, time = session))
}
}
example_parms <- exampleMapping[[input$example]]
if (input$dat_type == "example" & !is.null(example_parms$filters)) {
filter_vars <- example_parms$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0(input[[x]], collapse = ",")) else NULL
names(filter_vals) <- filter_vars
filter_vals <- as.data.frame(filter_vals)
} else if (input$dat_type %in% c("dat", "xlsx") & !is.null(input$filters)) {
filter_vars <- input$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0(input[[x]], collapse = ",")) else NULL
names(filter_vals) <- filter_vars
filter_vals <- as.data.frame(filter_vals)
} else {
filter_vars <- NULL
filter_vals <- NULL
}
summarize_ES(res,
filter_vals = filter_vals,
design = studyDesign(), method = input$method,
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
corStruct = input$corStruct,
varStruct = input$varStruct,
A = input$A_time, B = input$B_time,
coverage = input$coverage)
}
})
# Effect size output
output$effect_size_report <- renderTable({
effect_size()
}, digits = 4, include.rownames = FALSE)
output$download_ES <- downloadHandler(
filename = function() {
fname <- if (input$dat_type == "example") input$example else input$dat
paste(fname, '- effect size estimate.csv')
},
content = function(file) {
dat <- effect_size()
write.csv(dat, file, row.names=FALSE)
},
contentType = "text/csv"
)
# Graphs
raw_graph <- reactive({
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
graph_SCD(design = studyDesign(),
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
treatment_name = NULL, model_fit = NULL, data = datClean())
})
output$raw_plot <- renderPlot({
raw_graph()
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
output$HPS_plot <- renderPlot({
raw_graph() +
geom_smooth(formula = y ~ 1, method = "lm", se = FALSE)
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
output$RML_plot <- renderPlot({
if ("lme" %in% class(model_fit()$fit)) {
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
graph_SCD(design = studyDesign(),
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
model_fit = model_fit()$fit)
}
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
#------------------------------
# Syntax for replication in R
#------------------------------
ES_syntax <- reactive({
header_res <- c(
'# Load packages',
'library(nlme)',
'library(scdhlm)',
''
)
# read in file code
if(input$dat_type == "example") {
read_res <- c(
parse_code_chunk("load-example", args = list(example_name = input$example)),
''
)
} else if(input$dat_type == "dat"){
inFile <- input$dat
read_res <- c(
parse_code_chunk("load-dat",
args = list(user_path = inFile$name, user_header = input$header,
user_sep = input$sep, user_quote = input$quote)),
''
)
} else if (input$dat_type == "xlsx") {
inFile <- input$xlsx
read_res <- c(
parse_code_chunk("load-excel", args = list(user_path = inFile$name, user_sheet = input$inSelect)),
''
)
} else {
read_res <- c(
parse_code_chunk("load-from-function", args = NULL),
''
)
}
# Clean the data
if (input$degree_base == 0 || is.null(input$model_center)) {
model_center <- 0
} else {
model_center <- input$model_center
}
if (input$dat_type == "example") {
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0('"', input[[x]], '"', collapse = ",")) else NULL
filter_vals <- paste0("%in% c(", filter_vals, ")")
filter_string <- paste(example_parms$filters, filter_vals, collapse = " & ")
if (!is.null(example_parms$filters)) {
clean_dat_A <- c(
parse_code_chunk("clean-example-filter",
args = list(user_filterString = filter_string))
)
} else {
clean_dat_A <- c()
}
case <- "case"
session <- "session"
phase <- "phase"
outcome <- "outcome"
series <- "series"
cluster <- "cluster"
if (studyDesign() == "TR") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-TR",
args = list(user_parms = paste(example_parms$vars, collapse='", "'),
user_design = studyDesign()))
)
} else if (studyDesign() == "MBP") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter",
args = list(user_parms = paste(example_parms$vars, collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
} else if (studyDesign() == "RMBB") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-RMBB",
args = list(user_parms = paste(example_parms$vars[2:6], collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
} else if (studyDesign() == "CMB") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-CMB",
args = list(user_parms = paste(example_parms$vars[-c(1,2,7,9)], collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
}
} else {
case <- input$caseID
session <- input$session
phase <- input$phaseID
outcome <- input$outcome
cluster <- if (studyDesign() == "CMB") input$clusterID else "NULL"
series <- if (studyDesign() == "RMBB") input$seriesID else "NULL"
round_session <- if (!is.null(input$round_session)) TRUE else FALSE
filter_vars <- input$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0('"', input[[x]], '"', collapse = ",")) else NULL
filter_vals <- paste0("%in% c(", filter_vals, ")")
filter_string <- paste(input$filters, filter_vals, collapse = " & ")
if (!is.null(input$filters)) {
clean_dat_B <- c(
'',
parse_code_chunk("clean-inputdata-filter", args = list(user_filterString = filter_string))
)
} else {
clean_dat_B <- c()
}
if (studyDesign() == "TR") {
clean_dat <- c(clean_dat_B,
'',
parse_code_chunk("clean-inputdata-nofilter-TR",
args = list(user_caseID = case,
user_session = session,
user_phaseID = phase,
user_outcome = outcome,
user_design = studyDesign(),
user_treatment = input$treatment,
user_round = round_session))
)
} else if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
clean_dat <- c(clean_dat_B,
'',
parse_code_chunk("clean-inputdata-nofilter",
args = list(user_caseID = case,
user_session = session,
user_phaseID = phase,
user_outcome = outcome,
user_design = studyDesign(),
user_model_center = model_center,
user_treatment = input$treatment,
user_round = round_session,
user_clusterID = cluster,
user_seriesID = series))
)
}
}
# Fit the model
if (input$method=="RML") {
if (studyDesign() == "TR") {
session_FE <- if (is.null(input$FE_base) | !(0 %in% input$FE_base)) "0" else "1"
trt_FE <- if (is.null(input$FE_trt) | !(0 %in% input$FE_trt)) NULL else "trt"
session_RE <- if (is.null(input$RE_base) | !(0 %in% input$RE_base)) "0" else "1"
trt_RE <- if (is.null(input$RE_trt) | !(0 %in% input$RE_trt)) NULL else "trt"
} else {
session_FE <- write_formula(input$FE_base, c("0","1", session))
trt_FE <- write_formula(input$FE_trt, c("NULL", "trt", paste0(session, "_trt")))
session_RE <- write_formula(input$RE_base, c("0","1", session))
trt_RE <- write_formula(input$RE_trt, c("NULL","trt", paste0(session, "_trt")))
if (studyDesign() %in% c("RMBB", "CMB")) {
session_RE_2 <- write_formula(input$RE_base2, c("0","1", session))
trt_RE_2 <- write_formula(input$RE_trt2, c("NULL","trt", paste0(session, "_trt")))
}
}
fixed <- paste(outcome, "~", paste(c(session_FE, trt_FE), collapse = " + "))
if (studyDesign() == "RMBB") {
random <- paste0("list(", case, " = ~ ", paste(c(session_RE_2, trt_RE_2), collapse = " + "),
", ", series, " = ~ ", paste(c(session_RE, trt_RE), collapse = " + "),")")
} else if (studyDesign() == "CMB") {
random <- paste0("list(",cluster, " = ~ ", paste(c(session_RE_2, trt_RE_2), collapse = " + "),
", ", case, " = ~ ", paste(c(session_RE, trt_RE), collapse = " + "),")")
} else {
random <- paste("~", paste(c(session_RE, trt_RE), collapse = " + "), "|", case)
}
corr_struct <- switch(input$corStruct,
"AR(1)" =
if (studyDesign() == "RMBB") {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", case," / ", series, "),")
} else if (studyDesign() == "CMB") {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", cluster, " / ", case, "),")
} else {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", case, "),")
},
"MA(1)" =
if (studyDesign() == "RMBB") {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", case," / ", series, ", p = 0, q = 1),")
} else if (studyDesign() == "CMB") {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", cluster, " / ", case, ", p = 0, q = 1),")
} else {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", case, ", p = 0, q = 1),")
},
"IID" = "",
c())
var_struct <- switch(input$varStruct,
"hom" = "",
"het" = paste0("\n weights = varIdent(form = ~ 1 | ", phase, "),"),
c())
fit_mod <- parse_code_chunk("fit-RML", args = list(user_fixed = fixed,
user_random = random,
corr_struct = corr_struct,
var_struct = var_struct))
} else {
fit_mod <- c()
}
# Calculate effect size
if (input$method == "RML") {
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
A <- if (is.null(input$A_time)) 0L else input$A_time
B <- if (is.null(input$B_time)) 1L else input$B_time
p_const <- c(rep(0L, length(input$FE_base)), (B - A)^as.integer(input$FE_trt))
# get r_const when centering at an arbitrary time instead of B
r_dim <- length(input$RE_base) + length(input$RE_trt)
r_const_dim <- r_dim * (r_dim + 1) / 2
bc_vec <- (B - center)^as.integer(input$RE_base)
bc_mat <- 2 * tcrossprod(bc_vec) - diag(bc_vec^2)
r_const_base <- bc_mat[upper.tri(bc_mat, diag = TRUE)]
r_const_trt <- rep(0L, (r_const_dim - length(r_const_base)))
r_const_cor <- rep(0L, length(model_fit()$fit$modelStruct$corStruct))
r_const_var <- rep(0L, length(model_fit()$fit$modelStruct$varStruct))
if (studyDesign() %in% c("MBP", "TR")) {
r_const <- c(r_const_base, r_const_trt, r_const_cor, r_const_var, 1L)
} else {
r_dim2 <- length(input$RE_base2) + length(input$RE_trt2)
r_const_dim2 <- r_dim2 * (r_dim2 + 1) / 2
bc_vec2 <- (B - center)^as.integer(input$RE_base2)
bc_mat2 <- 2 * tcrossprod(bc_vec2) - diag(bc_vec2^2)
r_const_base2 <- bc_mat2[upper.tri(bc_mat2, diag = TRUE)]
r_const_trt2 <- rep(0L, r_const_dim2 - length(r_const_base2))
r_const <- c(r_const_base2, r_const_trt2, r_const_base, r_const_trt, r_const_cor, r_const_var, 1L)
}
if (studyDesign() == "MBP") {
calc_ES <- parse_code_chunk("es-RML-MB", args = list(user_A = A,
user_B = B,
user_FE_base = paste_object(input$FE_base),
user_FE_trt = paste_object(input$FE_trt),
user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
} else if (studyDesign() %in% c("RMBB", "CMB")) {
calc_ES <- parse_code_chunk("es-RML-3level", args = list(user_A = A,
user_B = B,
user_FE_base = paste_object(input$FE_base),
user_FE_trt = paste_object(input$FE_trt),
user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_base2 = paste_object(r_const_base2),
user_rconst_trt2 = paste_object(r_const_trt2),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
} else{
calc_ES <- parse_code_chunk("es-RML-TR", args = list(user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
}
} else {
if (studyDesign() == "MBP") {
calc_ES <- parse_code_chunk("es-MB", args = list(user_case = case,
user_session = session,
user_outcome = outcome))
} else {
phase_pair <- paste0(phase, "_pair")
calc_ES <- parse_code_chunk("es-ABK", args = list(user_case = case,
user_session = session,
user_outcome = outcome,
user_phase_pair = phase_pair))
}
}
furtherArg_design <- switch(studyDesign(),
"RMBB" = paste0("series = ", series, ","),
"CMB" = paste0("cluster = ", cluster, ","),
"MBP" = "",
"TR" = "",
c())
furtherArg_method <- switch(input$method,
"RML" = paste0("model_fit = fit_RML,"),
"HPS" = "",
c())
SCD_graph <- parse_code_chunk("graph-scd", args = list(user_case = case,
user_phase = phase,
user_session = session,
user_outcome = outcome,
user_design = studyDesign(),
furtherArg_method = furtherArg_method,
furtherArg_design = furtherArg_design))
res <- c(header_res, read_res, clean_dat, '', fit_mod, '', calc_ES, '', SCD_graph, '')
paste(res, collapse = "\n")
})
output$syntax <- renderPrint({
cat(ES_syntax(), sep = "\n")
})
output$clip <- renderUI({
rclipboard::rclipButton("clipbtn", "Copy", ES_syntax(), modal = FALSE, icon("clipboard"))
})
session$onSessionEnded(stopApp)
})
jepusto/scdhlm documentation built on Feb. 27, 2024, 4:45 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(shiny)
library(markdown)
library(ggplot2)
library(scdhlm)
library(readxl)
library(janitor)
source("mappings.R", local = TRUE)
source("helper-functions.R", local = TRUE)
source("lme-fit.R", local = TRUE)
server <-
shinyServer(function(input, output, session) {
if (exists("dataset", where = environment(server))) if (!is.null(dataset)) {
updateRadioButtons(
session,
inputId = 'dat_type',
label = 'What data do you want to use?',
choices = c("Use an example" = "example",
"Upload data from a .csv or .txt file" = "dat",
"Upload data from a .xlsx file" = "xlsx",
"Use the dataset specified at initialization" = "loaded"),
selected = "loaded"
)
}
sheetname <- reactive({
if (input$dat_type == "xlsx") {
inFile <- input$xlsx
if (is.null(inFile)) return(NULL)
sheetnames <- excel_sheets(inFile$datapath)
}
})
observe({
sheets <- sheetname()
updateSelectInput(session, "inSelect", label = "Select a sheet",
choices = sheets,
selected = sheets[1])
})
# Read in data
datFile <- reactive({
if (input$dat_type == "dat") {
inFile <- input$dat
if (is.null(inFile)) return(NULL)
read.table(inFile$datapath, header=input$header,
sep=input$sep, quote=input$quote,
stringsAsFactors = FALSE) %>%
clean_names(case = "parsed")
} else if (input$dat_type == "xlsx") {
inFile <- input$xlsx
if (is.null(inFile) || is.null(input$inSelect) || nchar(input$inSelect) == 0) return(NULL)
readxl::read_xlsx(inFile$datapath, col_names = input$col_names,
sheet = input$inSelect) %>%
clean_names(case = "parsed") %>%
as.data.frame()
} else if (input$dat_type == "loaded") {
dataset %>%
clean_names(case = "parsed")
}
})
# Check that file is uploaded
output$fileUploaded <- reactive({
return(!is.null(datFile()))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
# Study design with defaults
studyDesign <- reactive({
if (input$dat_type == "example") {
exampleMapping[[input$example]]$design
} else {
input$design
}
})
# Variable mapping interface
output$variableMapping <- renderUI({
var_names <- names(datFile())
n_var <- length(var_names)
if (studyDesign() %in% c("MBP", "TR")) {
list(
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
} else if (studyDesign() == "RMBB") {
list(
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 4]),
selectInput("seriesID", label = "Series identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
} else if (studyDesign() == "CMB") {
list(
selectInput("clusterID", label = "Cluster identifier", choices = var_names, selected = var_names[n_var - 4]),
selectInput("caseID", label = "Case identifier", choices = var_names, selected = var_names[n_var - 3]),
selectInput("phaseID", label = "Phase identifier", choices = var_names, selected = var_names[n_var - 2]),
selectInput("session", label = "Session number", choices = var_names, selected = var_names[n_var - 1])
)
}
})
variablesLoaded <- reactive({
if (is.null(input$caseID) | is.null(input$phaseID) | is.null(input$session) | is.null(input$outcome)) {
FALSE
} else {
(nchar(input$caseID) > 0) & (nchar(input$phaseID) > 0) & (nchar(input$session) > 0) & (nchar(input$outcome) > 0)
}
})
# Check Session variable
output$sessionIssues1 <- renderUI({
if (!variablesLoaded()) return(NULL)
sessions <- datFile()[,input$session]
if (!is.numeric(sessions) && !is.integer(sessions)) {
list(
strong(style="color:red", "Session variable contains non-numeric data."),
br("")
)
} else if (!isTRUE(all.equal(sessions, round(sessions)))) {
checkboxInput('round_session', 'Round Session variable to nearest integer?', TRUE)
}
})
output$sessionIssues2 <- renderUI({
if (!variablesLoaded()) return(NULL)
sessions <- datFile()[,input$session]
case_var <- datFile()[,input$caseID,drop=FALSE]
filter_vars <- datFile()[,input$filters,drop=FALSE]
split_vars <- cbind(case_var, filter_vars)
if (studyDesign() == "RMBB") {
series_var <- datFile()[, input$seriesID, drop=FALSE]
split_vars <- cbind(case_var, series_var, filter_vars)
} else if (studyDesign() == "CMB") {
cluster_var <- datFile()[, input$clusterID, drop=FALSE]
split_vars <- cbind(cluster_var, case_var, filter_vars)
}
if (length(split_vars) > 0 & is.numeric(sessions)) {
if (!is.null(input$round_session)) if (input$round_session) sessions <- round(sessions)
unique_sessions <- tapply(sessions, split_vars,
function(x) isTRUE(all.equal(x, unique(x))))
if (!all(unique_sessions, na.rm = TRUE)) {
list(
strong(style="color:red", "Session variable contains repeated values. Please ensure that each data point has a unique value within each case."),
br("")
)
}
}
})
output$outcomeMapping <- renderUI({
var_names <- names(datFile())
n_var <- length(var_names)
selectInput("outcome", label = "Outcome variable", choices = var_names, selected = var_names[n_var])
})
# Check Outcome variable
output$outcomeIssue <- renderUI({
if (!variablesLoaded()) return(NULL)
outcomes <- datFile()[,input$outcome]
if (!is.numeric(outcomes) && !is.integer(outcomes)) {
list(
strong(style="color:red", "Outcome variable contains non-numeric data. Please use a numeric outcome variable."),
br("")
)
}
})
# Treatment label mapping interface
output$phaseMapping <- renderUI({
if (!variablesLoaded()) return(NULL)
phases <- levels(as.factor(datFile()[,input$phaseID]))
list(
selectInput("baseline", label = "Baseline level", choices = phases, selected = phases[1]),
selectInput("treatment", label = "Treatment level", choices = phases, selected = phases[2])
)
})
# Filtering interface
output$filtervarMapping <- renderUI({
if (input$dat_type == "example") {
} else {
var_names <- names(datFile())
n_var <- length(var_names)
list(
selectizeInput("filters", label = "Filtering variables", choices = var_names, selected = NULL, multiple = TRUE)
)
}
})
output$filterMapping <- renderUI({
if (input$dat_type == "example") {
if (is.null(input$example)) return(NULL)
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
filter_vals <- lapply(filter_vars, function(x) example_parms[[paste0("filter_", x)]])
names(filter_vals) <- filter_vars
header <- strong("Please select the variables you wish to filter.")
} else {
filter_vars <- input$filters
filter_vals <- lapply(filter_vars, function(x) levels(as.factor(datFile()[,x])))
names(filter_vals) <- filter_vars
header <- strong("Values for the filtering variables.")
}
filter_selects <- lapply(filter_vars, function(x)
selectizeInput(paste0("filter_",x), label = x, choices = filter_vals[[x]],
selected = filter_vals[[x]][1], multiple = TRUE))
if (length(filter_vars) > 0) {
filter_selects <- list(header, column(12, br()), filter_selects)
}
filter_selects
})
# Clean the data
datClean <- reactive({
if (input$dat_type == "example") {
data(list = input$example)
dat <- get(input$example)
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
if (!is.null(filter_vars)) {
subset_vals <- sapply(filter_vars, function(x) levels(dat[[x]])[dat[[x]]] %in% input[[paste0("filter_",x)]])
dat <- dat[apply(subset_vals, 1, all),]
}
dat <- dat[,example_parms$vars]
if (studyDesign() %in% c("MBP", "TR")) {
names(dat) <- c("case","session","phase","outcome")
cluster <- series <- NULL
} else if (studyDesign() == "RMBB"){
names(dat) <- c("studyID","case", "series", "outcome", "session", "phase", "trt_time", "time_c")
cluster <- NULL
} else if (studyDesign() == "CMB") {
names(dat) <- c("studyID","school", "cluster", "case", "phase", "session", "session_trt", "outcome", "session_c")
series <- NULL
}
dat <- preprocess_SCD(design = studyDesign(),
cluster = cluster,
case = case, series = series,
phase = phase,
session = session, outcome = outcome,
data = dat)
} else {
case <- datFile()[,input$caseID]
phase <- datFile()[,input$phaseID]
session <- as.numeric(datFile()[,input$session])
outcome <- as.numeric(datFile()[,input$outcome])
cluster <- series <- NULL
dat <- data.frame(case = case, phase = phase, session = session, outcome = outcome)
if (studyDesign() == "RMBB") {
dat$series <- datFile()[,input$seriesID]
dat <- dat[order(dat$case, dat$series, dat$session),]
} else if (studyDesign() == "CMB") {
dat$cluster <- datFile()[,input$clusterID]
dat <- dat[order(dat$cluster, dat$case, dat$session),]
} else {
dat <- dat[order(dat$case, dat$session),]
}
if (!is.null(input$filters)) {
subset_vals <- sapply(input$filters, function(x) datFile()[[x]] %in% input[[paste0("filter_",x)]])
dat <- dat[apply(subset_vals, 1, all),]
}
design <- studyDesign()
round_session <- if (!is.null(input$round_session)) TRUE else FALSE
treatment_name <- input$treatment
dat <- preprocess_SCD(design = design,
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
round_session = round_session, treatment_name = treatment_name,
data = dat)
}
# if (studyDesign() == "MBP") {
# names(dat)[6] <- "session_trt"
# } else if (studyDesign() == "TR") {
# names(dat)[6] <- "phase_pair"
# } else if (studyDesign() %in% c("RMBB", "CMB")) {
# names(dat)[7] <- "session_trt"
# }
return(dat)
})
output$datTable <- renderTable(datClean())
# Estimation method
output$estMethod <- renderUI({
estimation_choices <- if (studyDesign() %in% c("MBP", "TR")) {
estimation_names
} else {
c("Restricted Maximum Likelihood" = "RML")
}
selectInput("method", label = "Estimation method",
choices = estimation_choices,
selected = "RML")
})
# Centering and timing sliders for RML estimation of MBD
time_range <- reactive({
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
default_times(
design = studyDesign(),
case = case, phase = phase, session = session,
cluster = cluster, series = series,
treatment_name = NULL, data = datClean()
)
})
output$model_centering <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML") {
session_range <- time_range()$range
sliderInput("model_center", "Center session at",
min=session_range[1], max=session_range[2],
value=time_range()$B, step = 1)
}
})
output$ES_timing_message <- renderText({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML" &
any(input$degree_trt != 0, (input$degree_base != 0 & input$RE_base > 0))) {
note_txt <- "Note: Options for selecting an initial treatment time and follow-up time can be modified on the next page."
HTML(note_txt)
}
})
output$ES_timing <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB") & input$method=="RML" &
any(input$degree_trt != 0, (input$degree_base != 0 & input$RE_base > 0))) {
timings <- time_range()
wellPanel(
fluidRow(
column(12,
h4("Hypothetical experimental parameters")
),
column(6,
sliderInput("A_time", "Initial treatment time",
min = timings$range[1], max = timings$range[2],
value = timings$A, step = 1)
),
column(6,
sliderInput("B_time", "Follow-up time",
min = timings$range[1], max = timings$range[2],
value = timings$B, step = 1)
)
)
)
}
})
# Model degree
output$modelDegree_baseline <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
selectInput("degree_base", label = "Type of time trend", choices = time_trends_baseline, width = "40%")
}
})
output$modelDegree_treatment <- renderUI({
if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
selectInput("degree_trt", label = "Type of time trend", choices = time_trends_treatment, width = "40%")
}
})
# Model specification
output$modelSpec_baseline <- renderUI({
deg_base <- if (is.null(input$degree_base)) 0 else as.numeric(input$degree_base)
degree_base_list <- 0:deg_base
names(degree_base_list) <- degree_names_baseline[1:(deg_base + 1)]
if (studyDesign() %in% c("MBP", "TR")) {
fluidRow(
column(6,
checkboxGroupInput("FE_base", labs_MBP$fixed, degree_base_list, selected = degree_base_list)
),
column(6,
checkboxGroupInput("RE_base", labs_MBP$random, degree_base_list, selected = 0)
)
)
} else if (studyDesign() == "RMBB") {
fluidRow(
column(4,
checkboxGroupInput("FE_base", labs_RMBB$fixed, degree_base_list, selected = degree_base_list)
),
column(4,
checkboxGroupInput("RE_base", labs_RMBB$random_series, degree_base_list, selected = 0)
),
column(4,
checkboxGroupInput("RE_base2", labs_RMBB$random_case, degree_base_list, selected = 0)
)
)
} else if (studyDesign() == "CMB") {
fluidRow(
column(4,
checkboxGroupInput("FE_base", labs_CMB$fixed, degree_base_list, selected = degree_base_list)
),
column(4,
checkboxGroupInput("RE_base", labs_CMB$random_case, degree_base_list, selected = 0)
),
column(4,
checkboxGroupInput("RE_base2", labs_CMB$random_cluster, degree_base_list, selected = 0)
)
)
}
})
output$modelSpec_treatment <- renderUI({
deg_trt <- if (is.null(input$degree_trt)) 0 else as.numeric(input$degree_trt)
degree_trt_list <- 0:deg_trt
names(degree_trt_list) <- degree_names_treatment[1:(deg_trt + 1)]
if (studyDesign() %in% c("MBP", "TR")) {
fluidRow(
column(6,
checkboxGroupInput("FE_trt", labs_MBP$fixed, degree_trt_list, selected = degree_trt_list)
),
column(6,
checkboxGroupInput("RE_trt", labs_MBP$random, degree_trt_list, selected = NULL)
)
)
} else if (studyDesign() == "RMBB") {
fluidRow(
column(4,
checkboxGroupInput("FE_trt", labs_RMBB$fixed, degree_trt_list, selected = degree_trt_list)
),
column(4,
checkboxGroupInput("RE_trt", labs_RMBB$random_series, degree_trt_list, selected = NULL)
),
column(4,
checkboxGroupInput("RE_trt2", labs_RMBB$random_case, degree_trt_list, selected = NULL)
)
)
} else if (studyDesign() == "CMB") {
fluidRow(
column(4,
checkboxGroupInput("FE_trt", labs_CMB$fixed, degree_trt_list, selected = degree_trt_list)
),
column(4,
checkboxGroupInput("RE_trt", labs_CMB$random_case, degree_trt_list, selected = NULL)
),
column(4,
checkboxGroupInput("RE_trt2", labs_CMB$random_cluster, degree_trt_list, selected = NULL)
)
)
}
})
# Validate model specification
model_validation <- reactive({
if (studyDesign() %in% c("MBP", "TR")) {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$case),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt)
} else if (studyDesign() == "RMBB") {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$case),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt,
RE_base2 = input$RE_base2, RE_trt2 = input$RE_trt2)
} else {
validate_specification(design = studyDesign(), n_outer_levels = nlevels(datClean()$cluster),
FE_base = input$FE_base, RE_base = input$RE_base,
FE_trt = input$FE_trt, RE_trt = input$RE_trt,
RE_base2 = input$RE_base2, RE_trt2 = input$RE_trt2)
}
})
output$model_spec <- renderUI({model_validation()})
# Fit model
model_fit <- reactive({
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
fit_function <- switch(studyDesign(),
MBP = "lme_fit_MB",
RMBB = "lme_fit_MB",
CMB = "lme_fit_MB",
TR = "lme_fit_TR")
if (studyDesign() %in% c("MBP", "TR")) {
RE_base2 <- RE_trt2 <- NULL
} else {
RE_base2 <- input$RE_base2
RE_trt2 <- input$RE_trt2
}
do.call(fit_function,
args = list(design = studyDesign(), dat = datClean(),
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
varStruct = input$varStruct,
corStruct = input$corStruct,
center = center))
})
# Model spec output
output$model_sample_size <- renderTable({
if (input$method == "RML") {
if (studyDesign() %in% c("MBP", "TR")) {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of groups" = nlevels(summary(model_fit()$fit)$groups$case),
check.names = FALSE)
} else if (studyDesign() == "CMB") {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of cases" = nlevels(summary(model_fit()$fit)$groups$case),
"Total number of clusters" = nlevels(summary(model_fit()$fit)$groups$cluster),
check.names = FALSE)
} else if (studyDesign() == "RMBB") {
data.frame("Total number of observations" = nobs(model_fit()$fit),
"Total number of series" = nlevels(summary(model_fit()$fit)$groups$series),
"Total number of cases" = nlevels(summary(model_fit()$fit)$groups$case),
check.names = FALSE)
}
}
},
caption = "Sample sizes",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_fixed <- renderTable({
if (input$method == "RML") {
summary(model_fit()$fit)$tTable
}
},
caption = "Fixed effects",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = TRUE)
output$model_fit_random <- renderTable({
if (input$method == "RML") {
random_table <- data.frame(VarCorr(model_fit()$fit)[])
rownames <- rownames(VarCorr(model_fit()$fit)[])
# set the rownames
if (studyDesign() %in% c("CMB", "RMBB")) {
row_index_lvl3 <- length(input$RE_base2)+length(input$RE_trt2)+1
rownames_lvl3 <- c("", rownames[2:row_index_lvl3])
rownames_lvl2 <- c("", rownames[(row_index_lvl3 + 2):(length(rownames))])
name_lvl3 <- if (studyDesign() == "CMB") "<strong>Cluster-level</strong>" else "<strong>Case-level</strong>"
name_lvl2 <- if (studyDesign() == "CMB") "<strong>Case-level</strong>" else "<strong>Series-level</strong>"
random_levels <- c(name_lvl3, rep("", row_index_lvl3-1), name_lvl2, rep("", (length(rownames)-row_index_lvl3-1)))
random_table[1, 1] <- NA # get rid of pdLogChol
random_table[(row_index_lvl3 + 1), 1] <- NA
random_table <- cbind("Level" = random_levels, "Rowname" = c(rownames_lvl3, rownames_lvl2), random_table)
random_table[, 3:4] <- lapply(random_table[, 3:4], function(x) as.numeric(x))
names(random_table)[2] <- ""
} else if (studyDesign() %in% c("MBP", "TR")) {
random_table <- cbind("Rowname" = rownames, random_table)
random_table[, 2:3] <- lapply(random_table[, 2:3], function(x) as.numeric(x))
names(random_table)[1] <- ""
}
# set the column names
columnnames <- names(random_table)
names(random_table) <- gsub("V[0-9]|Var.[0-9]", "", columnnames)
random_table
}
},
caption = "Random effects",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, na = "", include.rownames = FALSE, sanitize.text.function = function(x){x})
output$model_fit_corr <- renderTable({
if (input$method=="RML" & input$corStruct != "IID") {
data.frame(
"Correlation parameter" = effect_size()$`Auto-correlation`,
check.names = FALSE
)
}
},
caption = "Correlation structure",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_var <- renderTable({
if (input$method == "RML" & input$varStruct == "het") {
data.frame(
"Baseline" = 1,
"Treatment" = effect_size()$`Variance parameter`
)
}
},
caption = "Variance structure",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_info <- renderTable({
if (input$method == "RML") {
data.frame("AIC" = AIC(model_fit()$fit),
"BIC" = BIC(model_fit()$fit),
"Log likelihood" = as.numeric(model_fit()$fit$logLik),
check.names = FALSE)
}
},
caption = "Information criteria",
caption.placement = getOption("xtable.caption.placement", "top"),
digits = 4, include.rownames = FALSE)
output$model_fit_convg <- renderTable({
if (input$method=="RML") {
if (isTRUE(model_fit()$converged)) {
"The model converged."
} else {
"The model did not converge."
}
}
}, colnames = FALSE)
# Calculate effect sizes
effect_size <- reactive({
if ("lme" %in% class(model_fit()$fit)) {
if (studyDesign() %in% c("MBP", "TR")) {
RE_base2 <- RE_trt2 <- NULL
} else {
RE_base2 <- input$RE_base2
RE_trt2 <- input$RE_trt2
}
if (input$method=="RML") {
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
A <- if (is.null(input$A_time)) 0L else input$A_time
B <- if (is.null(input$B_time)) 1L else input$B_time
res <- effect_size_RML(design = studyDesign(), dat = datClean(),
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
varStruct = input$varStruct,
corStruct = input$corStruct,
A = A, B = B, center = center)
} else {
if (studyDesign()=="MBP") {
res <- with(datClean(), effect_size_MB(outcome = outcome, treatment = trt, id = case, time = session))
} else if (studyDesign()=="TR") {
res <- with(datClean(), effect_size_ABk(outcome = outcome, treatment = trt, id = case, phase = phase_pair, time = session))
}
}
example_parms <- exampleMapping[[input$example]]
if (input$dat_type == "example" & !is.null(example_parms$filters)) {
filter_vars <- example_parms$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0(input[[x]], collapse = ",")) else NULL
names(filter_vals) <- filter_vars
filter_vals <- as.data.frame(filter_vals)
} else if (input$dat_type %in% c("dat", "xlsx") & !is.null(input$filters)) {
filter_vars <- input$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0(input[[x]], collapse = ",")) else NULL
names(filter_vals) <- filter_vars
filter_vals <- as.data.frame(filter_vals)
} else {
filter_vars <- NULL
filter_vals <- NULL
}
summarize_ES(res,
filter_vals = filter_vals,
design = studyDesign(), method = input$method,
FE_base = input$FE_base, RE_base = input$RE_base, RE_base_2 = RE_base2,
FE_trt = input$FE_trt, RE_trt = input$RE_trt, RE_trt_2 = RE_trt2,
corStruct = input$corStruct,
varStruct = input$varStruct,
A = input$A_time, B = input$B_time,
coverage = input$coverage)
}
})
# Effect size output
output$effect_size_report <- renderTable({
effect_size()
}, digits = 4, include.rownames = FALSE)
output$download_ES <- downloadHandler(
filename = function() {
fname <- if (input$dat_type == "example") input$example else input$dat
paste(fname, '- effect size estimate.csv')
},
content = function(file) {
dat <- effect_size()
write.csv(dat, file, row.names=FALSE)
},
contentType = "text/csv"
)
# Graphs
raw_graph <- reactive({
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
graph_SCD(design = studyDesign(),
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
treatment_name = NULL, model_fit = NULL, data = datClean())
})
output$raw_plot <- renderPlot({
raw_graph()
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
output$HPS_plot <- renderPlot({
raw_graph() +
geom_smooth(formula = y ~ 1, method = "lm", se = FALSE)
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
output$RML_plot <- renderPlot({
if ("lme" %in% class(model_fit()$fit)) {
cluster <- if (studyDesign() == "CMB") substitute(cluster) else NULL
series <- if (studyDesign() == "RMBB") substitute(series) else NULL
graph_SCD(design = studyDesign(),
cluster = cluster, case = case, series = series,
phase = phase, session = session, outcome = outcome,
model_fit = model_fit()$fit)
}
}, height = function() 120 * nlevels(datClean()[[1]]),
width = function() 700)
#------------------------------
# Syntax for replication in R
#------------------------------
ES_syntax <- reactive({
header_res <- c(
'# Load packages',
'library(nlme)',
'library(scdhlm)',
''
)
# read in file code
if(input$dat_type == "example") {
read_res <- c(
parse_code_chunk("load-example", args = list(example_name = input$example)),
''
)
} else if(input$dat_type == "dat"){
inFile <- input$dat
read_res <- c(
parse_code_chunk("load-dat",
args = list(user_path = inFile$name, user_header = input$header,
user_sep = input$sep, user_quote = input$quote)),
''
)
} else if (input$dat_type == "xlsx") {
inFile <- input$xlsx
read_res <- c(
parse_code_chunk("load-excel", args = list(user_path = inFile$name, user_sheet = input$inSelect)),
''
)
} else {
read_res <- c(
parse_code_chunk("load-from-function", args = NULL),
''
)
}
# Clean the data
if (input$degree_base == 0 || is.null(input$model_center)) {
model_center <- 0
} else {
model_center <- input$model_center
}
if (input$dat_type == "example") {
example_parms <- exampleMapping[[input$example]]
filter_vars <- example_parms$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0('"', input[[x]], '"', collapse = ",")) else NULL
filter_vals <- paste0("%in% c(", filter_vals, ")")
filter_string <- paste(example_parms$filters, filter_vals, collapse = " & ")
if (!is.null(example_parms$filters)) {
clean_dat_A <- c(
parse_code_chunk("clean-example-filter",
args = list(user_filterString = filter_string))
)
} else {
clean_dat_A <- c()
}
case <- "case"
session <- "session"
phase <- "phase"
outcome <- "outcome"
series <- "series"
cluster <- "cluster"
if (studyDesign() == "TR") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-TR",
args = list(user_parms = paste(example_parms$vars, collapse='", "'),
user_design = studyDesign()))
)
} else if (studyDesign() == "MBP") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter",
args = list(user_parms = paste(example_parms$vars, collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
} else if (studyDesign() == "RMBB") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-RMBB",
args = list(user_parms = paste(example_parms$vars[2:6], collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
} else if (studyDesign() == "CMB") {
clean_dat <- c(clean_dat_A,
'',
parse_code_chunk("clean-example-nofilter-CMB",
args = list(user_parms = paste(example_parms$vars[-c(1,2,7,9)], collapse='", "'),
user_design = studyDesign(),
user_model_center = model_center))
)
}
} else {
case <- input$caseID
session <- input$session
phase <- input$phaseID
outcome <- input$outcome
cluster <- if (studyDesign() == "CMB") input$clusterID else "NULL"
series <- if (studyDesign() == "RMBB") input$seriesID else "NULL"
round_session <- if (!is.null(input$round_session)) TRUE else FALSE
filter_vars <- input$filters
filter_vals <- if(length(filter_vars) > 0) lapply(paste0("filter_", filter_vars),
function(x) paste0('"', input[[x]], '"', collapse = ",")) else NULL
filter_vals <- paste0("%in% c(", filter_vals, ")")
filter_string <- paste(input$filters, filter_vals, collapse = " & ")
if (!is.null(input$filters)) {
clean_dat_B <- c(
'',
parse_code_chunk("clean-inputdata-filter", args = list(user_filterString = filter_string))
)
} else {
clean_dat_B <- c()
}
if (studyDesign() == "TR") {
clean_dat <- c(clean_dat_B,
'',
parse_code_chunk("clean-inputdata-nofilter-TR",
args = list(user_caseID = case,
user_session = session,
user_phaseID = phase,
user_outcome = outcome,
user_design = studyDesign(),
user_treatment = input$treatment,
user_round = round_session))
)
} else if (studyDesign() %in% c("MBP", "RMBB", "CMB")) {
clean_dat <- c(clean_dat_B,
'',
parse_code_chunk("clean-inputdata-nofilter",
args = list(user_caseID = case,
user_session = session,
user_phaseID = phase,
user_outcome = outcome,
user_design = studyDesign(),
user_model_center = model_center,
user_treatment = input$treatment,
user_round = round_session,
user_clusterID = cluster,
user_seriesID = series))
)
}
}
# Fit the model
if (input$method=="RML") {
if (studyDesign() == "TR") {
session_FE <- if (is.null(input$FE_base) | !(0 %in% input$FE_base)) "0" else "1"
trt_FE <- if (is.null(input$FE_trt) | !(0 %in% input$FE_trt)) NULL else "trt"
session_RE <- if (is.null(input$RE_base) | !(0 %in% input$RE_base)) "0" else "1"
trt_RE <- if (is.null(input$RE_trt) | !(0 %in% input$RE_trt)) NULL else "trt"
} else {
session_FE <- write_formula(input$FE_base, c("0","1", session))
trt_FE <- write_formula(input$FE_trt, c("NULL", "trt", paste0(session, "_trt")))
session_RE <- write_formula(input$RE_base, c("0","1", session))
trt_RE <- write_formula(input$RE_trt, c("NULL","trt", paste0(session, "_trt")))
if (studyDesign() %in% c("RMBB", "CMB")) {
session_RE_2 <- write_formula(input$RE_base2, c("0","1", session))
trt_RE_2 <- write_formula(input$RE_trt2, c("NULL","trt", paste0(session, "_trt")))
}
}
fixed <- paste(outcome, "~", paste(c(session_FE, trt_FE), collapse = " + "))
if (studyDesign() == "RMBB") {
random <- paste0("list(", case, " = ~ ", paste(c(session_RE_2, trt_RE_2), collapse = " + "),
", ", series, " = ~ ", paste(c(session_RE, trt_RE), collapse = " + "),")")
} else if (studyDesign() == "CMB") {
random <- paste0("list(",cluster, " = ~ ", paste(c(session_RE_2, trt_RE_2), collapse = " + "),
", ", case, " = ~ ", paste(c(session_RE, trt_RE), collapse = " + "),")")
} else {
random <- paste("~", paste(c(session_RE, trt_RE), collapse = " + "), "|", case)
}
corr_struct <- switch(input$corStruct,
"AR(1)" =
if (studyDesign() == "RMBB") {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", case," / ", series, "),")
} else if (studyDesign() == "CMB") {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", cluster, " / ", case, "),")
} else {
paste0("\n correlation = corAR1(0.01, ~ ", session, " | ", case, "),")
},
"MA(1)" =
if (studyDesign() == "RMBB") {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", case," / ", series, ", p = 0, q = 1),")
} else if (studyDesign() == "CMB") {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", cluster, " / ", case, ", p = 0, q = 1),")
} else {
paste0("\n correlation = corARMA(0, ~ ", session, " | ", case, ", p = 0, q = 1),")
},
"IID" = "",
c())
var_struct <- switch(input$varStruct,
"hom" = "",
"het" = paste0("\n weights = varIdent(form = ~ 1 | ", phase, "),"),
c())
fit_mod <- parse_code_chunk("fit-RML", args = list(user_fixed = fixed,
user_random = random,
corr_struct = corr_struct,
var_struct = var_struct))
} else {
fit_mod <- c()
}
# Calculate effect size
if (input$method == "RML") {
center <- if (input$degree_base == 0 || is.null(input$model_center)) 0L else input$model_center
A <- if (is.null(input$A_time)) 0L else input$A_time
B <- if (is.null(input$B_time)) 1L else input$B_time
p_const <- c(rep(0L, length(input$FE_base)), (B - A)^as.integer(input$FE_trt))
# get r_const when centering at an arbitrary time instead of B
r_dim <- length(input$RE_base) + length(input$RE_trt)
r_const_dim <- r_dim * (r_dim + 1) / 2
bc_vec <- (B - center)^as.integer(input$RE_base)
bc_mat <- 2 * tcrossprod(bc_vec) - diag(bc_vec^2)
r_const_base <- bc_mat[upper.tri(bc_mat, diag = TRUE)]
r_const_trt <- rep(0L, (r_const_dim - length(r_const_base)))
r_const_cor <- rep(0L, length(model_fit()$fit$modelStruct$corStruct))
r_const_var <- rep(0L, length(model_fit()$fit$modelStruct$varStruct))
if (studyDesign() %in% c("MBP", "TR")) {
r_const <- c(r_const_base, r_const_trt, r_const_cor, r_const_var, 1L)
} else {
r_dim2 <- length(input$RE_base2) + length(input$RE_trt2)
r_const_dim2 <- r_dim2 * (r_dim2 + 1) / 2
bc_vec2 <- (B - center)^as.integer(input$RE_base2)
bc_mat2 <- 2 * tcrossprod(bc_vec2) - diag(bc_vec2^2)
r_const_base2 <- bc_mat2[upper.tri(bc_mat2, diag = TRUE)]
r_const_trt2 <- rep(0L, r_const_dim2 - length(r_const_base2))
r_const <- c(r_const_base2, r_const_trt2, r_const_base, r_const_trt, r_const_cor, r_const_var, 1L)
}
if (studyDesign() == "MBP") {
calc_ES <- parse_code_chunk("es-RML-MB", args = list(user_A = A,
user_B = B,
user_FE_base = paste_object(input$FE_base),
user_FE_trt = paste_object(input$FE_trt),
user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
} else if (studyDesign() %in% c("RMBB", "CMB")) {
calc_ES <- parse_code_chunk("es-RML-3level", args = list(user_A = A,
user_B = B,
user_FE_base = paste_object(input$FE_base),
user_FE_trt = paste_object(input$FE_trt),
user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_base2 = paste_object(r_const_base2),
user_rconst_trt2 = paste_object(r_const_trt2),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
} else{
calc_ES <- parse_code_chunk("es-RML-TR", args = list(user_rconst_base = paste_object(r_const_base),
user_rconst_trt = paste_object(r_const_trt),
user_rconst_cor = paste_object(r_const_cor),
user_rconst_var = paste_object(r_const_var),
user_pconstant = paste_object(p_const),
user_rconstant= paste_object(r_const)))
}
} else {
if (studyDesign() == "MBP") {
calc_ES <- parse_code_chunk("es-MB", args = list(user_case = case,
user_session = session,
user_outcome = outcome))
} else {
phase_pair <- paste0(phase, "_pair")
calc_ES <- parse_code_chunk("es-ABK", args = list(user_case = case,
user_session = session,
user_outcome = outcome,
user_phase_pair = phase_pair))
}
}
furtherArg_design <- switch(studyDesign(),
"RMBB" = paste0("series = ", series, ","),
"CMB" = paste0("cluster = ", cluster, ","),
"MBP" = "",
"TR" = "",
c())
furtherArg_method <- switch(input$method,
"RML" = paste0("model_fit = fit_RML,"),
"HPS" = "",
c())
SCD_graph <- parse_code_chunk("graph-scd", args = list(user_case = case,
user_phase = phase,
user_session = session,
user_outcome = outcome,
user_design = studyDesign(),
furtherArg_method = furtherArg_method,
furtherArg_design = furtherArg_design))
res <- c(header_res, read_res, clean_dat, '', fit_mod, '', calc_ES, '', SCD_graph, '')
paste(res, collapse = "\n")
})
output$syntax <- renderPrint({
cat(ES_syntax(), sep = "\n")
})
output$clip <- renderUI({
rclipboard::rclipButton("clipbtn", "Copy", ES_syntax(), modal = FALSE, icon("clipboard"))
})
session$onSessionEnded(stopApp)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.