Nothing
RT_DSC_rank_result <- reactive({
req(input$RT_Stats.DSC.Create_rank)
isolate({
withProgress({
data <- RT_DSC_data()
req(length(data) > 0)
test_type <- if (input$RT_Stats.DSC.Test_rank == "Anderson-Darling") "AD" else "KS"
rank_res <- get_dsc_rank(data, RT_stats_DSC_targets_obj, which = 'by_RT',
alpha = input$RT_Stats.DSC.Alpha_rank,
test_type = test_type,
monte_carlo_iterations = input$RT_Stats.DSC.MCsamples_rank,
epsilon = input$RT_Stats.DSC.Epsilon_rank,
na.correction = input$RT_Stats.DSC.Value_type)
if (is.null(rank_res)) {
shinyjs::alert("There was an error getting the ranking data from DSCtool. Please
select different settings and try again")
return(NULL)
}
updateSelectInput(session, 'RT_Stats.DSC.Omni_options', choices = rank_res$valid_methods,
selected = rank_res$valid_methods[[1]])
rank_res
}, message = "Getting DSC ranking data")
})
})
RT_render_performviz <- reactive({
rank_res <- RT_DSC_rank_result()
if (is.null(rank_res)) {return(NULL)}
Plot.Performviz(rank_res)
})
output$RT_Stats.DSC.PerformViz <- renderPlot({
RT_render_performviz()
})
output$RT_Stats.DSC.Download_rank_table <- downloadHandler(
filename = function() {
eval(RT_DSC_table_name_rank)
},
content = function(file) {
mlist <- RT_DSC_rank_result()$ranked_matrix
df <- rbindlist(lapply(seq(length(mlist)), function(problem_idx) {
df_temp <- rbindlist(lapply(mlist[[problem_idx]]$result,
function(x) {
list(algorithm = x$algorithm, rank = x$rank)
}))
df_temp[, problem := mlist[[problem_idx]]$problem]
}))
df2 <- reshape2::acast(df, algorithm ~ problem, value.var = 'rank')
save_table(df, file)
}
)
output$RT_Stats.DSC.Download_rank <- downloadHandler(
filename = function() {
eval(RT_DSC_figure_name_rank)
},
content = function(file) {
#Temporary settings, will replace plotting from complexheatmap to
#Some other plotly-compatible library later, and use save_plotly
suppressWarnings({
pdf(file = file, width = 16, height = 9)
RT_render_performviz()
dev.off()
})
},
contentType = paste0('image/', input$RT_Stats.DSC.Format_rank)
)
RT_DSC_omni_result <- reactive({
input$RT_Stats.DSC.Create_omni
isolate({
withProgress({
rank_res <- RT_DSC_rank_result()
req(rank_res)
omni_res <- get_dsc_omnibus(rank_res, method = input$RT_Stats.DSC.Omni_options,
alpha = input$RT_Stats.DSC.Alpha_omni)
}, message = "Creating Comparison, this might take a while")
})
})
output$RT_Stats.DSC.Output_omni <- renderText({
res_omni <- RT_DSC_omni_result()
req(res_omni)
paste0(res_omni$message, "(p-value: ", res_omni$p_value, ")")
})
RT_DSC_posthoc_result <- reactive({
input$RT_Stats.DSC.Create_posthoc
isolate({
withProgress({
omni_res <- RT_DSC_omni_result()
req(omni_res)
data <- RT_DSC_data()
req(length(data) > 0)
df_posthoc <- rbindlist(lapply(get_id(data), function(algname){
posthoc_res <- get_dsc_posthoc(omni_res, length(get_id(data)),
nrow(RT_stats_DSC_targets_obj),
alpha = input$RT_Stats.DSC.Alpha_posthoc,
base_algorithm = algname,
method = input$RT_Stats.DSC.Posthoc_test)
if (is.null(posthoc_res)) { return(NULL)}
values <- lapply(seq(4), function(method_idx) {
lapply(posthoc_res$adjusted_p_values[[method_idx]]$algorithms,
function(x) {
x$value
})
})
algnames <- lapply(posthoc_res$adjusted_p_values[[1]]$algorithms,
function(x) {
x$algorithm
})
df <- data.table("baseline" = algname, "compared alg" = algnames, z = values[[1]], "unadjusted P" = values[[2]],
"Holm" = values[[3]], "Hochberg" = values[[4]])
}))
as.data.table(format(df_posthoc, digits = 3))
}, message = "Creating Comparison, this might take a while")
})
})
output$RT_Stats.DSC.PosthocTable <- DT::renderDataTable({
req(length(DATA_RAW()) > 0)
RT_DSC_posthoc_result()
}, options = list(dom = 'lrtip', pageLength = 15, scrollX = T, server = T))
RT_render_DSC_plot <- reactive({
dt <- RT_DSC_posthoc_result()
if (is.null(dt) || nrow(dt) < 1) {return(NULL)}
# plot_general_data(dt[method == input$RT_Stats.DSC.method], x_attr = 'algId', y_attr = 'value', type = 'bar',
# legend_attr = 'algId')
dt <- dt[,c('baseline', 'compared alg', input$RT_Stats.DSC.Posthoc_method), with = F]
p_matrix <- acast(dt, baseline ~ `compared alg`, value.var = input$RT_Stats.DSC.Posthoc_method)
storage.mode(p_matrix) <- "numeric"
y <- p_matrix <= input$RT_Stats.DSC.Alpha_posthoc
colorScale <- data.frame(x = c(-1, -0.33, -0.33, 0.33, 0.33, 1),
col = c('blue', 'blue', 'white', 'white', 'red', 'red')
)
heatmap <- y - t(y)
p <- plot_ly(x = colnames(y), y = rownames(y), z = heatmap, type = 'heatmap',
xgap = 0.2, ygap = 0.2, colorscale = colorScale, showscale = F)
p %<>% layout(yaxis = list(autorange = 'reversed', scaleratio = 1),
xaxis = list(tickangle = 45))
p
})
output$RT_Stats.DSC.PosthocViz <- renderPlotly({
RT_render_DSC_plot()
})
output$RT_Stats.DSC.DownloadTable <- downloadHandler(
filename = function() {
eval(RT_DSC_table_name)
},
content = function(file) {
df <- RT_DSC_posthoc_result()
save_table(df, file)
}
)
output$RT_Stats.DSC.Download <- downloadHandler(
filename = function() {
eval(RT_DSC_figure_name)
},
content = function(file) {
save_plotly(RT_render_DSC_plot(), file)
},
contentType = paste0('image/', input$RT_Stats.DSC.Format)
)
RT_DSC_data <- function() {
data <- subset(DATA_RAW(), ID %in% isolate(input$RT_Stats.DSC.ID))
if (length(data) == 0) return(NULL)
data <- subset(data, DIM %in% input$RT_Stats.DSC.Dim)
data <- subset(data, funcId %in% input$RT_Stats.DSC.Funcid)
if (length(unique(get_id(data))) < 2) {
shinyjs::alert("This plot is only available when the dataset contains
multiple IDs for the selected functions and dimensions.")
return(NULL)
}
data
}
RT_stats_DSC_targets <- reactive({
data <- RT_DSC_data()
if (is.null(data)) return(NULL)
get_target_dt(data, "by_RT")
})
RT_stats_DSC_targets_obj <- NULL
proxy_RT_Stats.DSC.Targets <- dataTableProxy('RT_Stats.DSC.Targets')
output$RT_Stats.DSC.Targets <- DT::renderDataTable({
req(length(DATA_RAW()) > 0)
RT_stats_DSC_targets_obj <<- RT_stats_DSC_targets()
RT_stats_DSC_targets_obj
}, editable = list(target = 'cell', disable = list(columns = c(0,1))), rownames = FALSE,
options = list(pageLength = 5, lengthMenu = c(5, 10, 25, -1), scrollX = T, server = T))
observeEvent(input$RT_Stats.DSC.Targets_cell_edit, {
info <- input$RT_Stats.DSC.Targets_cell_edit
i <- info$row
j <- info$col
v <- info$value
data <- RT_DSC_data()
if (is.null(data)) return(NULL)
RT_stats_DSC_targets_obj$target[[i]] <<- v
replaceData(proxy, RT_stats_DSC_targets_obj, resetPaging = FALSE, rownames = FALSE)
})
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.