transfer from old repo

This commit is contained in:
Andreas Gammelgaard Damsbo 2026-08-19 09:27:27 +02:00
commit 277e2b8cf3
No known key found for this signature in database
1111 changed files with 83736 additions and 0 deletions

BIN
apps/.DS_Store vendored Normal file

Binary file not shown.

View file

@ -0,0 +1,134 @@
"ID","a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q"
"sub1",,,3,,,,,5,,,1,4,,,,2,
"sub2",,,,3,,5,,,,,,1,,2,,,4
"sub3",4,,,,2,,3,,,,,,,,,5,1
"sub4",,,,,2,,5,4,,,,1,,3,,,
"sub5",,,,5,,,2,,4,,1,,,,,3,
"sub6",,4,,,,,,,2,,1,,5,3,,,
"sub7",3,,,,,4,,,,,1,,,,2,5,
"sub8",,,,,2,,4,,1,,3,,,,,5,
"sub9",,3,,,,,,,1,5,,,4,,,,2
"sub10",,,,4,,,,,,3,,,5,,2,1,
"sub11",,5,,4,,,2,,1,,,,,3,,,
"sub12",,,2,5,,,,,,,,,3,4,,,1
"sub13",,,,5,,,,,,,,1,,3,2,,4
"sub14",,3,4,,,5,,,,,,,,,2,,1
"sub15",4,,,,5,,,2,1,,,,,,,,3
"sub16",5,,,2,4,,,,,,1,,,,3,,
"sub17",,4,,,3,1,5,,,,,,,2,,,
"sub18",,,,,1,2,,,3,5,,,,,,4,
"sub19",,,4,,,,3,,1,,2,,,,5,,
"sub20",,,2,,,,1,,,3,4,5,,,,,
"sub21",5,4,,,,2,,,,,1,,,,,,3
"sub22",,,,,1,,3,2,,,5,,,,4,,
"sub23",1,,,,4,,,,,,,,3,,2,,5
"sub24",,,5,,,,,,,,,1,4,2,,3,
"sub25",2,5,,,,3,,,,,,,,,,1,4
"sub26",,2,,5,,,4,,,,,,,,3,,1
"sub27",,,,,3,2,,,5,,,,,4,,1,
"sub28",,,5,,,,,4,,,1,,,2,,3,
"sub29",2,,,,,3,,,1,,5,4,,,,,
"sub30",,,,,,,1,,,4,,3,,,2,,5
"sub31",,,3,,,,,,,5,,1,,4,,,2
"sub32",3,,,,,,,,2,5,,1,,,4,,
"sub33",,2,,,4,,1,5,,,,,,3,,,
"sub34",,,3,1,,,,4,,,5,,,,,,2
"sub35",1,4,,,,,,2,,,,,,,3,5,
"sub36",,5,,3,,4,1,2,,,,,,,,,
"sub37",,,4,,3,,,,,,,1,2,5,,,
"sub38",,,,4,,,,3,,,,2,,1,5,,
"sub39",5,,,,1,4,,2,,,,,,3,,,
"sub40",,,,,4,2,5,1,,,,,,,3,,
"sub41",,1,,,,3,,5,,,,4,2,,,,
"sub42",,,,,,3,,,,,,1,5,,2,,4
"sub43",,,,,,,,,,,1,,3,,4,2,5
"sub44",,4,,,,,,,,,2,,,5,3,,1
"sub45",2,3,,,,,4,,1,,,,,,,,5
"sub46",,3,,,4,,,,,5,1,,,,,,2
"sub47",,2,1,,5,,,,,3,,4,,,,,
"sub48",,2,,,1,3,,,,,5,4,,,,,
"sub49",,,,1,,,,3,,,,2,,,,4,5
"sub50",3,,,,,,,5,,1,,,4,,,2,
"sub51",,,1,3,4,,,,2,,,,,,,5,
"sub52",,,1,,,,,,,4,5,,,,2,3,
"sub53",,,,2,5,,,,,1,,3,,,,4,
"sub54",,,,3,,,,,4,,,1,,2,,5,
"sub55",,,2,,,,4,,,,,,1,3,5,,
"sub56",,,,,,,,,3,,1,5,4,2,,,
"sub57",,,4,,2,,1,,,,,3,,,,,5
"sub58",,3,,,,,,,,,,4,,,1,5,2
"sub59",,,,4,,,1,,3,,5,2,,,,,
"sub60",,,,,,,,2,,,,1,3,5,,4,
"sub61",,,1,,,3,,2,4,,,,,5,,,
"sub62",1,2,,,,,,5,,4,,,,,,3,
"sub63",,2,,,3,,4,,,,,,,5,,,1
"sub64",,,5,,,1,2,,,,3,,,,,,4
"sub65",1,,3,2,,,,,,4,,,5,,,,
"sub66",,,,,,,1,,,,,2,,4,5,,3
"sub67",4,5,,,,,2,,1,,,,,3,,,
"sub68",3,,,2,5,,4,,,1,,,,,,,
"sub69",5,,1,,,,4,,,,,3,,,2,,
"sub70",,2,,,,5,1,,,,3,,4,,,,
"sub71",5,,,,4,2,,1,,,3,,,,,,
"sub72",5,,,4,1,,,,,,3,,,,,2,
"sub73",5,3,,,,,,,4,,,1,,,2,,
"sub74",,5,,2,,3,,,4,,,,,,,,1
"sub75",,,,,,,,,4,1,,5,2,,,,3
"sub76",,1,,,,,2,5,4,,,3,,,,,
"sub77",5,,,,,,3,,,,,,,1,2,,4
"sub78",4,,,,,,1,3,,2,,,,,,5,
"sub79",,,,3,,,,,,,4,1,5,,2,,
"sub80",,2,,,5,4,,,,,,,,,1,3,
"sub81",,,4,,,,2,,1,,,3,,,,,5
"sub82",5,,,,,,,2,4,,,3,,,,,1
"sub83",,2,,,,,4,5,1,,,,,,3,,
"sub84",,,,3,1,,,,,,2,,4,,,5,
"sub85",,,,1,4,,,5,,,,,,,2,,3
"sub86",,,3,,,,,5,1,,,2,4,,,,
"sub87",,,,,2,5,4,,,,,,1,,,3,
"sub88",,,,,,,,,,,,2,3,1,,4,5
"sub89",,,5,2,,,4,,,,,,,1,,3,
"sub90",,5,,1,,,,,,4,,3,,2,,,
"sub91",5,,,,,3,,,4,,2,,,1,,,
"sub92",,,,,,4,,5,,,2,,,,1,3,
"sub93",,,,,1,,,,,4,2,,5,,,3,
"sub94",1,,,,,,2,,,,,,4,5,,,3
"sub95",,,,,4,2,3,,,5,,1,,,,,
"sub96",,5,,2,,,1,,,,,3,,4,,,
"sub97",1,3,,,,,,4,2,,,,,,5,,
"sub98",,,5,,3,,,,,,1,,,2,4,,
"sub99",,,4,,,,,5,,,,,1,3,2,,
"sub100",,2,,,,4,5,,,3,,,1,,,,
"sub101",,3,,1,2,,,,,,4,,,,,,5
"sub102",1,,,2,,5,,,,,,3,,,,4,
"sub103",,3,,,,,5,,1,,,,,2,,,4
"sub104",,5,,4,,1,2,3,,,,,,,,,
"sub105",,,,2,5,,,3,4,,1,,,,,,
"sub106",,,,4,5,3,2,,,,,1,,,,,
"sub107",2,1,3,,,,,,5,,4,,,,,,
"sub108",,,4,,,,,,,1,,,5,,2,,3
"sub109",,4,,,,,,2,1,,,5,,3,,,
"sub110",,,,,3,,,,1,,,,,4,5,,2
"sub111",,,,,,3,,,4,1,,,,,,2,5
"sub112",,1,,,,,,,2,5,,,3,,,4,
"sub113",,,3,,,,,,,,1,5,,4,2,,
"sub114",,,,,1,3,,,,,5,,4,,2,,
"sub115",,1,,,4,2,,,,,3,5,,,,,
"sub116",,2,4,,,3,,5,1,,,,,,,,
"sub117",,,,,,2,,,,4,,1,,5,,3,
"sub118",,4,5,,,1,,,3,,,,,2,,,
"sub119",5,,,3,,,1,,,4,,,2,,,,
"sub120",1,2,4,,,,,,,,,,5,,,,3
"sub121",,2,,,,5,,,,,,1,3,,,,4
"sub122",3,,1,5,,,,,,,,4,,2,,,
"sub123",,1,3,,,,4,5,,,,,,,,2,
"sub124",,,2,,,4,,,,3,,,,,5,,1
"sub125",,,,2,,,,,,,4,1,,5,,,3
"sub126",,,,2,5,,3,,4,,,,,,,1,
"sub127",4,,,,,1,2,,,,,,5,3,,,
"sub128",,,,,1,4,,,,,,3,,,,2,5
"sub129",,,,3,1,2,,4,,,,5,,,,,
"sub130",4,,,,1,,,5,,3,2,,,,,,
"sub131",,,,,1,3,,,,5,2,,,,,,4
"sub132",,,,,2,,5,,,,3,,1,,,,4
"sub133",,4,,,,,,3,,,,,,1,,2,5
1 ID a b c d e f g h i j k l m n o p q
2 sub1 3 5 1 4 2
3 sub2 3 5 1 2 4
4 sub3 4 2 3 5 1
5 sub4 2 5 4 1 3
6 sub5 5 2 4 1 3
7 sub6 4 2 1 5 3
8 sub7 3 4 1 2 5
9 sub8 2 4 1 3 5
10 sub9 3 1 5 4 2
11 sub10 4 3 5 2 1
12 sub11 5 4 2 1 3
13 sub12 2 5 3 4 1
14 sub13 5 1 3 2 4
15 sub14 3 4 5 2 1
16 sub15 4 5 2 1 3
17 sub16 5 2 4 1 3
18 sub17 4 3 1 5 2
19 sub18 1 2 3 5 4
20 sub19 4 3 1 2 5
21 sub20 2 1 3 4 5
22 sub21 5 4 2 1 3
23 sub22 1 3 2 5 4
24 sub23 1 4 3 2 5
25 sub24 5 1 4 2 3
26 sub25 2 5 3 1 4
27 sub26 2 5 4 3 1
28 sub27 3 2 5 4 1
29 sub28 5 4 1 2 3
30 sub29 2 3 1 5 4
31 sub30 1 4 3 2 5
32 sub31 3 5 1 4 2
33 sub32 3 2 5 1 4
34 sub33 2 4 1 5 3
35 sub34 3 1 4 5 2
36 sub35 1 4 2 3 5
37 sub36 5 3 4 1 2
38 sub37 4 3 1 2 5
39 sub38 4 3 2 1 5
40 sub39 5 1 4 2 3
41 sub40 4 2 5 1 3
42 sub41 1 3 5 4 2
43 sub42 3 1 5 2 4
44 sub43 1 3 4 2 5
45 sub44 4 2 5 3 1
46 sub45 2 3 4 1 5
47 sub46 3 4 5 1 2
48 sub47 2 1 5 3 4
49 sub48 2 1 3 5 4
50 sub49 1 3 2 4 5
51 sub50 3 5 1 4 2
52 sub51 1 3 4 2 5
53 sub52 1 4 5 2 3
54 sub53 2 5 1 3 4
55 sub54 3 4 1 2 5
56 sub55 2 4 1 3 5
57 sub56 3 1 5 4 2
58 sub57 4 2 1 3 5
59 sub58 3 4 1 5 2
60 sub59 4 1 3 5 2
61 sub60 2 1 3 5 4
62 sub61 1 3 2 4 5
63 sub62 1 2 5 4 3
64 sub63 2 3 4 5 1
65 sub64 5 1 2 3 4
66 sub65 1 3 2 4 5
67 sub66 1 2 4 5 3
68 sub67 4 5 2 1 3
69 sub68 3 2 5 4 1
70 sub69 5 1 4 3 2
71 sub70 2 5 1 3 4
72 sub71 5 4 2 1 3
73 sub72 5 4 1 3 2
74 sub73 5 3 4 1 2
75 sub74 5 2 3 4 1
76 sub75 4 1 5 2 3
77 sub76 1 2 5 4 3
78 sub77 5 3 1 2 4
79 sub78 4 1 3 2 5
80 sub79 3 4 1 5 2
81 sub80 2 5 4 1 3
82 sub81 4 2 1 3 5
83 sub82 5 2 4 3 1
84 sub83 2 4 5 1 3
85 sub84 3 1 2 4 5
86 sub85 1 4 5 2 3
87 sub86 3 5 1 2 4
88 sub87 2 5 4 1 3
89 sub88 2 3 1 4 5
90 sub89 5 2 4 1 3
91 sub90 5 1 4 3 2
92 sub91 5 3 4 2 1
93 sub92 4 5 2 1 3
94 sub93 1 4 2 5 3
95 sub94 1 2 4 5 3
96 sub95 4 2 3 5 1
97 sub96 5 2 1 3 4
98 sub97 1 3 4 2 5
99 sub98 5 3 1 2 4
100 sub99 4 5 1 3 2
101 sub100 2 4 5 3 1
102 sub101 3 1 2 4 5
103 sub102 1 2 5 3 4
104 sub103 3 5 1 2 4
105 sub104 5 4 1 2 3
106 sub105 2 5 3 4 1
107 sub106 4 5 3 2 1
108 sub107 2 1 3 5 4
109 sub108 4 1 5 2 3
110 sub109 4 2 1 5 3
111 sub110 3 1 4 5 2
112 sub111 3 4 1 2 5
113 sub112 1 2 5 3 4
114 sub113 3 1 5 4 2
115 sub114 1 3 5 4 2
116 sub115 1 4 2 3 5
117 sub116 2 4 3 5 1
118 sub117 2 4 1 5 3
119 sub118 4 5 1 3 2
120 sub119 5 3 1 4 2
121 sub120 1 2 4 5 3
122 sub121 2 5 1 3 4
123 sub122 3 1 5 4 2
124 sub123 1 3 4 5 2
125 sub124 2 4 3 5 1
126 sub125 2 4 1 5 3
127 sub126 2 5 3 4 1
128 sub127 4 1 2 5 3
129 sub128 1 4 3 2 5
130 sub129 3 1 2 4 5
131 sub130 4 1 5 3 2
132 sub131 1 3 5 2 4
133 sub132 2 5 3 1 4
134 sub133 4 3 1 2 5

Binary file not shown.

View file

@ -0,0 +1,188 @@
group_assignment <-
function(ds,
cap_classes = NULL,
excess_space = NULL,
pre_assign = NULL) {
require(dplyr)
require(tidyr)
require(ROI)
require(ROI.plugin.symphony)
require(ompr)
require(ompr.roi)
if (!is.data.frame(ds)){
stop("Supplied data has to be a data frame, with each row
are subjects and columns are groups, with the first column being
subject identifiers")}
## This program very much trust the user to supply correctly formatted data
cost <- t(ds[,-1]) #Transpose converts to matrix
colnames(cost) <- ds[,1]
num_groups <- dim(cost)[1]
num_sub <- dim(cost)[2]
## Adding the option to introduce a bit of head room to the classes by
## the groups to a little bigger than the smallest possible
## Default is to allow for an extra 20 % fill
if (is.null(excess_space)) {
excess <- 1.2
} else {
excess <- excess_space
}
# generous round up of capacities
if (is.null(cap_classes)) {
capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups)
# } else if (!is.numeric(cap_classes)) {
# stop("cap_classes has to be numeric")
} else if (length(cap_classes)==1){
capacity <- ceiling(rep(cap_classes,num_groups)*excess)
} else if (length(cap_classes)==num_groups){
capacity <- ceiling(cap_classes*excess)
} else {
stop("cap_classes has to be either length 1 or same as number of groups")
}
## This test should be a little more elegant
## pre_assign should be a data.frame or matrix with an ID and assignment column
with_pre_assign <- FALSE
if (!is.null(pre_assign)){
# Setting flag for later and export list
with_pre_assign <- TRUE
# Splitting to list for later merging
pre <- split(pre_assign[,1],factor(pre_assign[,2],levels = seq_len(num_groups)))
# Subtracting capacity numbers, to reflect already filled spots
capacity <- capacity-lengths(pre)
# Making sure pre_assigned are removed from main data set
ds <- ds[!ds[[1]] %in% pre_assign[[1]],]
cost <- t(ds[,-1])
colnames(cost) <- ds[,1]
num_groups <- dim(cost)[1]
num_sub <- dim(cost)[2]
}
## Simple NA handling. Better to handle NAs yourself!
cost[is.na(cost)] <- num_groups
i_m <- seq_len(num_groups)
j_m <- seq_len(num_sub)
m <- MIPModel() %>%
add_variable(grp[i, j],
i = i_m,
j = j_m,
type = "binary") %>%
## The first constraint says that group size should not exceed capacity
add_constraint(sum_expr(grp[i, j], j = j_m) <= capacity[i],
i = i_m) %>%
## The second constraint says each subject can only be in one group
add_constraint(sum_expr(grp[i, j], i = i_m) == 1, j = j_m) %>%
## The objective is set to minimize the cost of the assignments
## Giving subjects the group with the highest possible ranking
set_objective(sum_expr(
cost[i, j] * grp[i, j],
i = i_m,
j = j_m
),
"min") %>%
solve_model(with_ROI(solver = "symphony", verbosity = 1))
## Getting assignments
solution <- get_solution(m, grp[i, j]) %>% filter(value > 0)
assign <- solution |> select(i,j)
if (!is.null(rownames(cost))){
assign$i <- rownames(cost)[assign$i]
}
if (!is.null(colnames(cost))){
assign$j <- colnames(cost)[assign$j]
}
## Splitting into groups based on assignment
assign_ls <- split(assign$j,assign$i)
## Extracting subject cost for the final assignment for evaluation
if (is.null(rownames(cost))){
rownames(cost) <- seq_len(nrow(cost))
}
if (is.null(colnames(cost))){
colnames(cost) <- seq_len(ncol(cost))
}
eval <- lapply(seq_len(length(assign_ls)),function(i){
ndx <- match(names(assign_ls)[i],rownames(cost))
cost[ndx,assign_ls[[i]]]
})
names(eval) <- names(assign_ls)
if (with_pre_assign){
names(pre) <- names(assign_ls)
assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE)
out <- list(all_assigned=assign_all)
} else {
out <- list(all_assigned=assign_ls)
}
export <- do.call(rbind,lapply(seq_along(out[[1]]),function(i){
cbind("ID"=out[[1]][[i]],"Group"=names(out[[1]])[i])
}))
out <- append(out,
list(evaluation=eval,
assigned=assign_ls,
solution = solution,
capacity = capacity,
excess = excess,
pre_assign = with_pre_assign,
cost_scale = levels(factor(cost)),
input=ds,
export=export))
# exists("excess")
return(out)
}
## Assessment performance overview
## The function plots costs of assignment for each subject in every group
assignment_plot <- function(lst){
dl <- lst[[2]]
cost_scale <- unique(lst[[8]])
cap <- lst[[5]]
cnts_ls <- lapply(dl,function(i){
factor(i,levels=cost_scale)
})
require(ggplot2)
require(patchwork)
require(viridisLite)
y_max <- max(lengths(dl))
wrap_plots(lapply(seq_along(dl),function(i){
ttl <- names(dl)[i]
ns <- length(dl[[i]])
cnts <- cnts_ls[[i]]
ggplot() + geom_bar(aes(cnts,fill=cnts)) +
scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) +
scale_y_continuous(name = NULL, limits = c(0,y_max)) +
scale_fill_manual(values = viridisLite::viridis(length(cost_scale), direction = -1)) +
guides(fill=FALSE) + labs(title=paste0(ttl," (fill=",round(ns/cap[[i]],1),";m=",round(mean(dl[[i]]),1),";n=",ns ,")"))
}))
}
## Helper function for Shiny
file_extension <- function(filenames) {
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "", filenames, perl = TRUE)
}

View file

@ -0,0 +1,11 @@
"ID","group"
"sub36",16
"sub105",10
"sub112",3
"sub61",15
"sub27",8
"sub78",7
"sub110",1
"sub129",2
"sub109",12
"sub46",14
1 ID group
2 sub36 16
3 sub105 10
4 sub112 3
5 sub61 15
6 sub27 8
7 sub78 7
8 sub110 1
9 sub129 2
10 sub109 12
11 sub46 14

View file

@ -0,0 +1,10 @@
name: assignment
title:
username: cognitiveindex
account: cognitiveindex
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 9832455
bundleId: 7671734
url: https://cognitiveindex.shinyapps.io/assignment/
version: 1

96
apps/Assignment/server.R Normal file
View file

@ -0,0 +1,96 @@
server <- function(input, output, session) {
library(dplyr)
library(tidyr)
library(ROI)
library(ROI.plugin.symphony)
library(ompr)
library(ompr.roi)
library(magrittr)
library(ggplot2)
library(viridisLite)
library(patchwork)
library(openxlsx)
# source("https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/raw/branch/main/side%20projects/assignment.R")
source("group_assign.R")
dat <- reactive({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
# Make laoding dependent of file name extension (file_ext())
ext <- file_extension(input$file1$datapath)
if (ext == "csv") {
df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',""))
} else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
}
return(df)
})
dat_pre <- reactive({
# req(input$file2)
# Make laoding dependent of file name extension (file_ext())
if (!is.null(input$file2$datapath)){
ext <- file_extension(input$file2$datapath)
if (ext == "csv") {
df <- read.csv(input$file2$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx::read.xlsx(input$file2$datapath,na.strings = c("NA", '""',""))
} else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
}
return(df)
} else {
return(NULL)
}
})
assign <-
reactive({
assigned <- group_assignment(
ds = dat(),
excess_space = input$ecxess,
pre_assign = dat_pre()
)
return(assigned)
})
output$raw.data.tbl <- renderTable({
assign()$export
})
output$pre.assign <- renderTable({
dat_pre()
})
output$input <- renderTable({
dat()
})
output$assign.plt <- renderPlot({
assignment_plot(assign())
})
# Downloadable csv of selected dataset ----
output$downloadData <- downloadHandler(
filename = "group_assignment.csv",
content = function(file) {
write.csv(assign()$export, file, row.names = FALSE)
}
)
}

123
apps/Assignment/ui.R Normal file
View file

@ -0,0 +1,123 @@
library(shiny)
library(ggplot2)
ui <- fluidPage(
## -----------------------------------------------------------------------------
## Application title
## -----------------------------------------------------------------------------
titlePanel("Assign groups based on costs/priorities.",
windowTitle = "Group assignment calculator"),
h5(
"Please note this calculator is only meant as a proof of concept for educational purposes,
and the author will take no responsibility for the results of the calculator.
Uploaded data is not kept, but please, do not upload any sensitive data."
),
## -----------------------------------------------------------------------------
## Side panel
## -----------------------------------------------------------------------------
## -----------------------------------------------------------------------------
## Single entry
## -----------------------------------------------------------------------------
sidebarLayout(
sidebarPanel(
numericInput(
inputId = "ecxess",
label = "Excess space",
value = 1,
step = .05
),
p("As default, the program will try to evenly distribute subjects in groups.
This factor will add more capacity to each group, for an overall lesser cost,
but more uneven group numbers. More adjustments can be performed with the source script."),
a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"),
## -----------------------------------------------------------------------------
## File upload
## -----------------------------------------------------------------------------
# Input: Select a file ----
fileInput(
inputId = "file1",
label = "Choose main data file",
multiple = FALSE,
accept = c(
".csv",".xls",".xlsx"
)
),
strong("Columns: ID, group1, group2, ... groupN."),
strong("NOTE: 0s will be interpreted as lowest score."),
p("Cells should contain cost/priorities.
Lowest score, for highest priority.
Non-ranked should contain a number (eg lowest score+1).
Will handle missings but try to avoid."),
fileInput(
inputId = "file2",
label = "Choose data file for pre-assigned subjects",
multiple = FALSE,
accept = c(
".csv",".xls",".xlsx"
)
),
h6("Columns: ID, group"),
## -----------------------------------------------------------------------------
## Download output
## -----------------------------------------------------------------------------
# Horizontal line ----
tags$hr(),
h4("Download results"),
# Button
downloadButton("downloadData", "Download")
),
mainPanel(tabsetPanel(
## -----------------------------------------------------------------------------
## Plot tab
## -----------------------------------------------------------------------------
tabPanel(
"Summary",
h3("Assignment plot"),
p("These plots are to summarise simple performance meassures for the assignment.
'f' is group fill fraction and 'm' is mean cost in group."),
plotOutput("assign.plt")
),
tabPanel(
"Results",
h3("Raw Results"),
p("This is identical to the downloaded file (see panel on left)"),
htmlOutput("raw.data.tbl", container = span)
),
tabPanel(
"Input data Results",
h3("Costs/prioritis overview"),
htmlOutput("input", container = span),
h3("Pre-assigned groups"),
p("Appears empty if none is uploaded."),
htmlOutput("pre.assign", container = span)
)
))
)
)

View file

@ -0,0 +1,42 @@
## -----------------------------------------------------------------------------
## Cognitive Index app
## -----------------------------------------------------------------------------
##
## This app is created to demonstrate the index-lookup of a certain cognitive test.
## The results a provided with no responsibility of validity.
## Do not upload sensitive data when using the app.
##
## /AG Damsbo
##
## -- START WITH THIS -- ##
old_wd<-getwd()
setwd(paste0(old_wd,"/apps/Index app"))
shiny::runApp()
source(paste0(old_wd,"/apps/app_deploy.R"))
setwd(old_wd)
## Poor mans changelog
## 18aug2022 Its alive!!
## https://cognitiveindex.shinyapps.io/index_app/
##
## 19aug2022 - 1
## Now live with a choice between single entry or file upload, and download option for results in both cases.
## Wishlist:
## - Still missing is a better labelling, however this works for now.
##
## Sources:
## - How about uploading dataset? https://shiny.rstudio.com/articles/upload.html
## - And then download: https://shiny.rstudio.com/articles/download.html
##
## Now moved to my PhysicalActivityandStrokeOutcome-repository.
##
## 19aug2022 - 2
## Now table headers are updated. Done for now!
##
##

View file

@ -0,0 +1,39 @@
## -----------------------------------------------------------------------------
## Group assignment app
## -----------------------------------------------------------------------------
##
## Special cases to consider
## - duplicate scores - DON'T CARE
## - missing scores - DONE
## - Pre-assignment of special cases - SOLVED
## - Make sure to remove assigned subjects from all subjects when pre-assigning - DONE
## - Set class to output list and have plot function only accept correct class (not necessary for Shiny)
## - Use knitr::kable() to show sample data, alternatively use gt() - DONE
## - Handle [NA, 0, ""] - DONE
##
## I believe we are ready for a shiny app!
## -- START WITH THIS -- ##
old_wd<-getwd()
setwd(paste0(old_wd,"/apps/Assignment"))
setwd(old_wd)
## Run app
shiny::runApp(appDir = here::here("apps/Assignment"),launch.browser = TRUE)
## App deployment
require(rsconnect)
keys<-suppressWarnings(read.csv("/Users/au301842/shinyapp_token.csv",colClasses = "character"))
rsconnect::setAccountInfo(name='cognitiveindex',
token=keys$key[1], secret=keys$key[2])
deployApp(appDir = "/Users/au301842/PAaSO/apps/Assignment")
## Raw sketch, doesn't load correctly...

22
apps/HWE Calc test app.R Normal file
View file

@ -0,0 +1,22 @@
## -----------------------------------------------------------------------------
## HWE Calc test app deployment
## -----------------------------------------------------------------------------
##
## This app was written as proof of concept for my Research year program,
## as no online calculators were found to calculate the
## Hardy-Weinberg-equilibrium of allele distributions.
##
## Source: https://raw.githubusercontent.com/agdamsbo/daDoctoR/master/R/hwe_geno.R
##
## /AG Damsbo
##
old_wd<-getwd()
setwd(paste0(old_wd,"/apps/HWE Calc"))
shiny::runApp()
source(paste0(old_wd,"/apps/app_deploy.R"))
setwd(old_wd)

View file

@ -0,0 +1,11 @@
name: hwe_calc
title:
username:
account: cognitiveindex
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 6803322
bundleId: 6213208
url: https://cognitiveindex.shinyapps.io/hwe_calc/
when: 1660807491.6397
lastSyncTime: 1660807491.63971

69
apps/HWE Calc/server.R Normal file
View file

@ -0,0 +1,69 @@
server <- function(input, output, session) {
cale <- reactive({
as.numeric(input$ale)
})
dat<-reactive({
df<-data.frame(lbls=c("MM","MN","NN","MO","NO","OO"),
value=rbind(input$mm,input$mn,input$nn,input$mo,input$no,input$oo),
stringsAsFactors = FALSE)
print(df)
df
})
cmm <- reactive({
as.numeric(input$mm)
})
cmn <- reactive({
as.numeric(input$mn)
})
cnn <- reactive({
as.numeric(input$nn)
})
cmo <- reactive({
as.numeric(input$mo)
})
cno <- reactive({
as.numeric(input$no)
})
coo <- reactive({
as.numeric(input$oo)
})
hwe_p <- function() ({ hwe_geno(cmm(),cmn(),cnn(),cmo(),cno(),coo(),alleles=cale()) })
output$allele.tbl <- renderTable({ hwe_p()$allele.dist })
output$obs.tbl <- renderTable({ hwe_p()$observed.dist })
output$exp.tbl <- renderTable({ hwe_p()$expected.dist })
output$chi.val <- renderTable({ hwe_p()$chi.value })
output$p.val <- renderTable({ hwe_p()$p.value })
output$allele.dist <- renderText({"Allele distribution"})
output$obs.dist <- renderText({"Observed distribution"})
output$exp.dist <- renderText({"Expected distribution"})
output$chi <- renderText({"Chi square value"})
output$p <- renderText({"P value"})
output$geno.pie.plt<- renderPlot({
ggplot(dat(), aes(x="", y=value, fill=lbls))+
geom_bar(width = 1, stat = "identity")+
coord_polar("y", start=0)+
scale_fill_brewer(palette="Dark2")
})
output$geno.pie.ttl <- renderText({"Genotype distribution"})
}

85
apps/HWE Calc/ui.R Normal file
View file

@ -0,0 +1,85 @@
source("https://raw.githubusercontent.com/agdamsbo/daDoctoR/master/R/hwe_geno.R")
library(shiny)
library(ggplot2)
ui <- fluidPage(
# Application title
titlePanel("Chi square test of HWE for bi- or triallelic systems"),
sidebarLayout(
sidebarPanel(
# Input: Numeric entry for number of alleles ----
radioButtons(inputId = "ale",
label = "Number of alleles:",
inline = FALSE,
choiceNames=c("Two alleles (M, N)",
"Three alleles (M, N, O)"),
choiceValues=c(2,3)),
h4("Observed genotype distribution"),
numericInput(inputId = "mm",
label = "MM:",
value=NA),
numericInput(inputId = "mn",
label = "MN:",
value=NA),
numericInput(inputId = "nn",
label = "NN:",
value=NA),
conditionalPanel(condition = "input.ale==3",
numericInput(inputId = "mo",
label = "MO:",
value=NA),
numericInput(inputId = "no",
label = "NO:",
value=NA),
numericInput(inputId = "oo",
label = "OO:",
value=NA))
),
mainPanel(
tabsetPanel(
tabPanel("Summary",
h3(textOutput("obs.dist", container = span)),
htmlOutput("obs.tbl", container = span),
h3(textOutput("exp.dist", container = span)),
htmlOutput("exp.tbl", container = span),
h3(textOutput("allele.dist", container = span)),
htmlOutput("allele.tbl", container = span),
value=1),
tabPanel("Calculations",
h3(textOutput("chi", container = span)),
htmlOutput("chi.val", container = span),
h3(textOutput("p", container = span)),
htmlOutput("p.val", container = span),
value=2),
tabPanel("Plots",
h3(textOutput("geno.pie.ttl", container = span)),
plotOutput("geno.pie.plt"),
value=3),
selected= 2, type = "tabs")
)
)
)

View file

@ -0,0 +1,9 @@
name: index_app
title:
username:
account: cognitiveindex
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 6803928
bundleId: 8182645
url: https://cognitiveindex.shinyapps.io/index_app/

View file

@ -0,0 +1,24 @@
# Samlpe data from data base
source("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/src/redcap_api_export_short.R")
df<-redcap_api_export_short(id= c(40:45),
instruments= "rbans",
event= "3_months_arm_1") %>%
select(c("record_id",ends_with(c("_version","_age","_rs")))) %>%
na.omit()|>
rbind(redcap_api_export_short(id= c(10:15),
instruments= "rbans",
event= "12_months_arm_1") %>%
select(c("record_id",ends_with(c("_version","_age","_rs")))) %>%
na.omit())
colnames(df)<-c("record_id","ab","age","imm","vis","ver","att","del")
## New index numbers
df$record_id<-1:nrow(df)
## Age is changed for obscurity
df$age<-sample(-2:2,nrow(df),TRUE)+df$age
write.csv(df, "sample.csv", row.names = FALSE)

13
apps/Index app/sample.csv Normal file
View file

@ -0,0 +1,13 @@
"record_id","ab","age","imm","vis","ver","att","del"
1,1,67,26,31,24,42,38
2,1,69,34,31,27,40,34
3,1,63,43,35,29,46,38
4,1,66,45,37,30,54,40
5,1,66,44,34,33,54,44
6,1,83,39,34,23,37,31
7,2,71,49,37,24,52,42
8,2,81,33,30,39,47,42
9,2,61,50,38,36,52,56
10,2,88,32,20,26,13,30
11,2,73,36,28,22,34,33
12,2,89,22,30,21,29,30
1 record_id ab age imm vis ver att del
2 1 1 67 26 31 24 42 38
3 2 1 69 34 31 27 40 34
4 3 1 63 43 35 29 46 38
5 4 1 66 45 37 30 54 40
6 5 1 66 44 34 33 54 44
7 6 1 83 39 34 23 37 31
8 7 2 71 49 37 24 52 42
9 8 2 81 33 30 39 47 42
10 9 2 61 50 38 36 52 56
11 10 2 88 32 20 26 13 30
12 11 2 73 36 28 22 34 33
13 12 2 89 22 30 21 29 30

104
apps/Index app/server.R Normal file
View file

@ -0,0 +1,104 @@
server <- function(input, output, session) {
library(dplyr)
library(ggplot2)
library(tidyr)
source("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/src/plot_index.R")
source("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/src/index_from_raw.R")
dat<-reactive({
df<-data.frame(record_id="1",
ab=input$version,
age=input$age,
imm=input$rs1,
vis=input$rs2,
ver=input$rs3,
att=input$rs4,
del=input$rs5,
stringsAsFactors = FALSE)
return(df)
})
dat_u<-reactive({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
req(input$file1)
df <- read.csv(input$file1$datapath,
header = input$header,
sep = input$sep,
quote = input$quote)
return(df)
})
dat_f<-reactive({
if (input$type==1){
return(dat())}
if (input$type==2){
return(head(dat_u(),10))}
})
index_p <- reactive({ df<-index_from_raw(ds=dat_f(),
indx=read.csv("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/data/index.csv"),
version = dat_f()$ab,
age = dat_f()$age,
raw_columns=c("imm","vis","ver","att","del"))
colnames(df)<-c("id",
"a_is",
"b_is",
"c_is",
"d_is",
"e_is",
"i_is",
"a_ci",
"b_ci",
"c_ci",
"d_ci",
"e_ci",
"i_ci",
"a_per",
"b_per",
"c_per",
"d_per",
"e_per",
"i_per")
return(df)
})
output$ndx.tbl <- renderTable({
index_p()|>
select("id",contains("_is"))
})
output$per.tbl <- renderTable({
index_p()|>
select("id",contains("_per"))
})
output$ndx.plt<-renderPlot({
plot_index(index_p(),sub_plot = "_is")
})
output$per.plt<-renderPlot({
plot_index(index_p(),sub_plot = "_per")
})
# Downloadable csv of selected dataset ----
output$downloadData <- downloadHandler(
filename = "index_lookup.csv",
content = function(file) {
write.csv(index_p(), file, row.names = FALSE)
}
)
}

View file

@ -0,0 +1,18 @@
df<-data.frame(record_id="1",
imm=35,
vis=35,
ver=35,
att=35,
del=35,
stringsAsFactors = FALSE)
source("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/src/index_from_raw.R")
df_c<-index_from_raw(ds=df,
indx=read.csv("https://raw.githubusercontent.com/agdamsbo/ENIGMAtrial_R/main/data/index.csv"),
version = "1",
age = 60,
raw_columns=c("imm","vis","ver","att","del"),
mani=TRUE)
plot_index(ds=df_c,id="id",sub_plot = "_is")

152
apps/Index app/ui.R Normal file
View file

@ -0,0 +1,152 @@
library(shiny)
library(ggplot2)
ui <- fluidPage(
## -----------------------------------------------------------------------------
## Application title
## -----------------------------------------------------------------------------
titlePanel("Calculating cognitive index scores in multidimensional testing.",
windowTitle = "Cognitive test index calculator"),
h5("Please note this calculator is only meant as a proof of concept for educational purposes,
and the author will take no responsibility for the results of the calculator.
Uploaded data is not kept, but please, do not upload any sensitive data."),
## -----------------------------------------------------------------------------
## Side panel
## -----------------------------------------------------------------------------
sidebarPanel(
h4("Test resultsData format"),
radioButtons(inputId = "type",
label = "Data type",
inline = FALSE,
choiceNames=c("Single entry",
"File upload (10 records)"),
choiceValues=c(1,2)),
# Horizontal line ----
tags$hr(),
## -----------------------------------------------------------------------------
## Single entry
## -----------------------------------------------------------------------------
conditionalPanel(condition = "input.type==1",
numericInput(inputId = "age",
label = "Age",
value=60),
radioButtons(inputId = "version",
label = "Test version (A/B)",
inline = FALSE,
choiceNames=c("A",
"B"),
choiceValues=c(1,2)),
numericInput(inputId = "rs1",
label = "Immediate memory",
value=35),
numericInput(inputId = "rs2",
label = "Visuospatial functions",
value=35),
numericInput(inputId = "rs3",
label = "Verbal functions",
value=30),
numericInput(inputId = "rs4",
label = "Attention",
value=35),
numericInput(inputId = "rs5",
label = "Delayed memory",
value=40)
),
## -----------------------------------------------------------------------------
## File upload
## -----------------------------------------------------------------------------
conditionalPanel(condition = "input.type==2",
# Input: Select a file ----
fileInput("file1", "Choose CSV File",
multiple = FALSE,
accept = c("text/csv",
"text/comma-separated-values,text/plain",
".csv")),
h6("Columns: record_id, ab, age, imm, vis, ver, att, del."),
# Horizontal line ----
tags$hr(),
# Input: Checkbox if file has header ----
checkboxInput("header", "Header", TRUE),
# Input: Select separator ----
radioButtons("sep", "Separator",
choices = c(Comma = ",",
Semicolon = ";",
Tab = "\t"),
selected = ","),
# Input: Select quotes ----
radioButtons("quote", "Quote",
choices = c(None = "",
"Double Quote" = '"',
"Single Quote" = "'"),
selected = '"'),
),
## -----------------------------------------------------------------------------
## Download output
## -----------------------------------------------------------------------------
# Horizontal line ----
tags$hr(),
h4("Download results"),
# Button
downloadButton("downloadData", "Download")
),
mainPanel(
tabsetPanel(
## -----------------------------------------------------------------------------
## Summary tab
## -----------------------------------------------------------------------------
tabPanel("Summary",
h3("Index Scores"),
htmlOutput("ndx.tbl", container = span),
h3("Percentiles"),
htmlOutput("per.tbl", container = span)
),
## -----------------------------------------------------------------------------
## Plots tab
## -----------------------------------------------------------------------------
tabPanel("Plots",
h3("Index Scores"),
plotOutput("ndx.plt"),
h3("Percentiles"),
plotOutput("per.plt")
)
)
)
)

16
apps/app_deploy.R Normal file
View file

@ -0,0 +1,16 @@
## Cognitive Index app deployment
require(rsconnect)
# keys <- suppressWarnings(read.csv("/Users/au301842/shinyapp_token.csv", colClasses = "character"))
#
# keyring::key_get(service = "rsconnect_cognitiveindex_token")
# keyring::key_get(service = "rsconnect_cognitiveindex_secret")
rsconnect::setAccountInfo(
name = "cognitiveindex",
token = keyring::key_get(service = "rsconnect_cognitiveindex_token"),
secret = keyring::key_get(service = "rsconnect_cognitiveindex_secret")
)
rsconnect::deployApp(appDir = here::here("app"))

79
apps/shinyDAG-1.0.0/.gitignore vendored Normal file
View file

@ -0,0 +1,79 @@
# ---- Project files ----
shiny_bookmarks/
www/errors/*
# ---- Default .gitignore From grkmisc ----
.Rproj.user
.Rhistory
.RData
.DS_Store
# Directories that start with _
_*/
## https://github.com/github/gitignore/blob/master/R.gitignore
# History files
.Rhistory
.Rapp.history
# Session Data files
.RData
# Example code in package build process
*-Ex.R
# Output files from R CMD build
/*.tar.gz
# Output files from R CMD check
/*.Rcheck/
# RStudio files
.Rproj.user/
# produced vignettes
vignettes/*.html
vignettes/*.pdf
# OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3
.httr-oauth
# knitr and R markdown default cache directories
/*_cache/
/cache/
# Temporary files created by R markdown
*.utf8.md
*.knit.md
# Shiny token, see https://shiny.rstudio.com/articles/shinyapps.html
rsconnect/
## https://github.com/github/gitignore/blob/master/Global/macOS.gitignore
# General
.DS_Store
.AppleDouble
.LSOverride
# Icon must end with two \r
Icon
# Thumbnails
._*
# Files that might appear in the root of a volume
.DocumentRevisions-V100
.fseventsd
.Spotlight-V100
.TemporaryItems
.Trashes
.VolumeIcon.icns
.com.apple.timemachine.donotpresent
# Directories potentially created on remote AFP share
.AppleDB
.AppleDesktop
Network Trash Folder
Temporary Items
.apdisk

View file

@ -0,0 +1,27 @@
sudo: required
services:
- docker
env:
global:
- DOCKER_USER="grrrck"
- DOCKER_ORG="gerkelab"
- secure: "cHdDyac1V5loCeGFS9k+hTejr2cRUWHm5vDB+7vXajkw4ile4mcn+E5vdoy9ExXlaHYuqjrOqURyBAI/HY1U0O06Brif9W8cKlUn7SGwaM6coBgqAxjeOiFDVD9Xg8IOI7wCHjJr9heMRLZyd65cyh9l30S+VKMqx4oFmoYdkvj2v7veDsN9j6kJ7SYGSZOmgv9G/FZmQvyWyLLhpgzMw98WzS2/QsbhG8ZSUmlRYfXo+B1vgw1lDVn8iRFAjG3oFiY4qXTVeaBOi/qAY20Kd44qQpcb2CL1wV/zMjRFGLXtlaBoMMA/4s5uRrFfJHsqUxLIqmhuBlLtqOtyZd2CqP3EGSjkmxfNh/dMDA0zgd3o/IVLuz6owpbHR/9ypUKvuD91vtTp0BUM+6Uma9j+ODC2Zn+IBi6QogjBSBkzz8wEK3TdM2RdjtJ62lBCL8YWxmGCQfIGR+emo1BUFnCsgMYsscC5LoMzFaihBTZAqaMQ3grCi743F2ozHFB3J2DRId1QZD+nje8An3ALsa152BX+ItblyOD7MxfSXa6OtthlholPTiKhYyWBncQqFMBaYsglVVF8MONEYJUzbws2D7+0IdJ5sXZz8XM/sXUwxNkBIpjfQoaqOkYFILCkwab59D7AvZPyYb6hI+XRhvqvA7Z221d+6UloRCFJha/oaR8="
- COMMIT=${TRAVIS_COMMIT::8}
- REPO="shinydag"
script:
- docker build -f Dockerfile -t $DOCKER_ORG/$REPO:$COMMIT .
after_success:
- docker login -u $DOCKER_USER -p $DOCKER_PASS
- if [[ $TRAVIS_PULL_REQUEST == "false" ]] && [[ $TRAVIS_BRANCH == "master" ]]; then
docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:latest;
docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:$TRAVIS_BUILD_NUMBER;
docker push $DOCKER_ORG/$REPO;
fi
- if [[ $TRAVIS_PULL_REQUEST == "false" ]] && [[ $TRAVIS_BRANCH == "dev" ]]; then
docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:dev;
docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:$TRAVIS_BUILD_NUMBER;
docker push $DOCKER_ORG/$REPO;
fi

View file

@ -0,0 +1,64 @@
FROM rocker/shiny-verse:3.5.3
LABEL maintainer="Travis Gerke (Travis.Gerke@moffitt.org)"
# Install system dependencies for required packages
RUN apt-get update -qq && apt-get -y --no-install-recommends install \
libssl-dev \
libxml2-dev \
libmagick++-dev \
libv8-3.14-dev \
libglu1-mesa-dev \
freeglut3-dev \
mesa-common-dev \
libudunits2-dev \
libpoppler-cpp-dev \
libwebp-dev \
&& apt-get clean \
&& rm -rf /var/lib/apt/lists/ \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error \
shinyAce \
shinydashboard \
shinyWidgets \
DiagrammeR \
ggdag \
igraph \
pdftools \
shinyBS \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN Rscript -e "devtools::install_github('metrumresearchgroup/texPreview', ref = 'e954322')" \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
# Install TinyTeX
RUN install2.r --error tinytex \
&& wget -qO- \
"https://github.com/yihui/tinytex/raw/master/tools/install-unx.sh" | \
sh -s - --admin --no-path \
&& mv ~/.TinyTeX /opt/TinyTeX \
&& /opt/TinyTeX/bin/*/tlmgr path add \
&& tlmgr install metafont mfware inconsolata tex ae parskip listings \
&& tlmgr install standalone varwidth xcolor colortbl multirow psnfss setspace pgf \
&& tlmgr path add \
&& Rscript -e "tinytex::r_texmf()" \
&& chown -R root:staff /opt/TinyTeX \
&& chmod -R a+w /opt/TinyTeX \
&& chmod -R a+wx /opt/TinyTeX/bin \
&& echo "PATH=${PATH}" >> /usr/local/lib/R/etc/Renviron \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error shinyjs \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error plotly shinycssloaders \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN installGithub.r gadenbuie/shinyThings@4e8becb2972aa2f7f1960da6e5fe6ad39aeceda0 \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
ARG SHINY_APP_IDLE_TIMEOUT=600
RUN sed -i "s/directory_index on;/app_idle_timeout ${SHINY_APP_IDLE_TIMEOUT};/g" /etc/shiny-server/shiny-server.conf
COPY . /srv/shiny-server/shinyDAG
RUN chown -R shiny:shiny /srv/shiny-server/

Binary file not shown.

After

Width:  |  Height:  |  Size: 769 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 760 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 216 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 30 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 46 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 39 KiB

View file

@ -0,0 +1,21 @@
MIT License
Copyright (c) 2018 Jordan Creed and Travis Gerke
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

View file

@ -0,0 +1,183 @@
# * ui_edge_controls() builds an individual UI control element. These elements
# are re-rendered whenever the tab is opened, so this function finds the
# current value of the input and uses that instead of the value declared
# in the definition in ui_edge_controls_row(). This function also isolates
# the edge control UI from other changes in nodes, etc, because they happen
# on different screens.
ui_controls <- function(hash, inputFn, prefix_input, label, ..., input = NULL) {
stopifnot(!is.null(input))
current_value_arg_name <- intersect(names(list(...)), c("selected", "value"))
if (!length(current_value_arg_name)) {
stop("Must specifiy `selected` or `value` when specifying edge UI controls")
}
input_name <- paste(prefix_input, hash, sep = "__")
input_label <- label
if (input_name %in% names(isolate(input))) {
# Make sure current value doesn't change
dots <- list(...)
dots[current_value_arg_name] <- paste(isolate(input[[input_name]]))
dots$inputId <- input_name
dots$label <- HTML(input_label)
do.call(inputFn, dots)
} else {
# Create new input
inputFn(input_name, HTML(input_label), ...)
}
}
get_hashed_input_with_prefix <- function(input, prefix, hash_sep = "__") {
prefix <- glue::glue("^({prefix}){hash_sep}")
tibble(
inputId = grep(prefix, names(input), value = TRUE)
) %>%
filter(!grepl("-selectized$", inputId)) %>%
# get current value of input
mutate(value = lapply(inputId, function(x) input[[x]])) %>%
tidyr::separate(inputId, into = c("var", "hash"), sep = hash_sep) %>%
tidyr::spread(var, value) %>%
mutate_if(is.list, ~ purrr::map(.x, ~ if (is.null(.x)) NA else .x)) %>%
tidyr::unnest() %>%
split(.$hash)
}
# The input for angles (here for easy refactoring or future changes)
selectDegree <- function(inputId, label = "Degree", min = -180, max = 180, by = 15, value = 0, ...) {
sliderInput(inputId, label = label, min = min, max = max, value = value, step = by)
}
# Edge Aesthetic UI -------------------------------------------------------
# These helper functions build up the Edge UI elements.
#
# * ui_edge_controls_row() creates the entire row of UI elements for a given
# edge. This function is where the UI inputs are initially defined.
ui_edge_controls_row <- function(hash, from_name, to_name, ..., input = NULL) {
stopifnot(!is.null(input))
extra <- list(...)
col_4 <- function(x) {
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
}
title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x))
edge_label <- paste0(from_name, "&nbsp;&#8594; ", to_name)
tagList(
fluidRow(
title_row(HTML(edge_label))
),
fluidRow(
# Edge Curve Angle
col_4(ui_controls(
hash,
inputFn = selectDegree,
prefix_input = "angle",
label = "Angle",
value = extra[["angle"]] %||% 0,
width = "95%",
input = input
)),
# Edge Color
col_4(ui_controls(
hash,
inputFn = xcolorPicker,
prefix_input = "color",
label = "Edge",
selected = extra[["color"]] %||% "Black",
width = "95%",
input = input
)),
# Curve Angle
col_4(ui_controls(
hash,
inputFn = selectInput,
prefix_input = "lty",
label = "Line Type",
choices = c("solid", "dashed"),
selected = extra[["lty"]] %||% "solid",
width = "95%",
input = input
)),
# Curve Angle
col_4(ui_controls(
hash,
inputFn = selectInput,
prefix_input = "lineT",
label = "Line Thickness",
choices = c("ultra thin", "very thin", "thin", "semithick", "thick", "very thick", "ultra thick"),
selected = extra[["lineT"]] %||% "thin",
width = "95%",
input = input
))
)
)
}
# Node Aesthetic UI -------------------------------------------------------
ui_node_controls_row <- function(hash, name, adjusted, name_latex, ..., input = NULL) {
stopifnot(!is.null(input))
extra <- list(...)
col_4 <- function(x) {
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
}
title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x))
tagList(
fluidRow(
title_row(HTML(name))
),
fluidRow(
# LaTeX version of node label
col_4(ui_controls(
hash,
inputFn = textInput,
prefix_input = "name_latex",
label = "LaTeX Label",
value = name_latex,
width = "95%",
input = input
)),
# Text Color
col_4(ui_controls(
hash,
inputFn = xcolorPicker,
prefix_input = "color_text",
label = "Text",
selected = extra[["color_text"]] %||% "Black",
width = "95%",
input = input
)),
# Fill Color
col_4(ui_controls(
hash,
inputFn = xcolorPicker,
prefix_input = "color_fill",
label = "Fill",
selected = extra[["color_fill"]] %||% "White",
width = "95%",
input = input
)),
# Box Color (if shown)
if (adjusted) {
col_4(ui_controls(
hash,
inputFn = xcolorPicker,
prefix_input = "color_draw",
label = "Border",
selected = extra[["color_draw"]] %||% "Black",
width = "95%",
input = input
))
}
)
)
}

View file

@ -0,0 +1,28 @@
class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12"
# Component Builders ------------------------------------------------------
two_column_flips_on_mobile <- function(left, right, override_width_classes = TRUE) {
left_col_class <- "col-sm-12 col-md-pull-6 col-md-6 col-lg-5 col-lg-pull-7"
right_col_class <- "col-sm-12 col-md-push-6 col-md-6 col-lg-7 col-lg-push-5"
if (!override_width_classes) {
right <- tags$div(class = right_col_class, right)
left <- tags$div(class = left_col_class, left)
} else {
strip_col_class <- function(x) gsub("col-(xs|sm|md|lg)-\\d{1,2}\\s*", "", x)
left$attrib$class <- strip_col_class(left$attrib$class)
right$attrib$class <- strip_col_class(right$attrib$class)
left$attrib$class <- paste(left$attrib$class, left_col_class)
right$attrib$class <- paste(right$attrib$class, right_col_class)
}
fluidRow(right, left)
}
col_4 <- function(x) {
tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x)
}

View file

@ -0,0 +1,114 @@
# rve$edges is a named list, e.g. for hash(A) -> hash(B):
# rve$edges[edge_key(hash(A), hash(B))] = list(from = hash(A), to = hash(B))
# ---- Edge Helper Functions ----
edge_key <- function(x, y) digest::digest(c(x, y))
edge_frame <- function(edges, nodes, ...) {
dots <- rlang::enexprs(...)
dag_edges <- edges_in_dag(edges, nodes)
if (!length(dag_edges)) return(tibble())
ensure_exists <- function(x, ...) {
cols <- list(...)
stopifnot(!is.null(names(cols)), all(nzchar(names(cols))))
for (col in names(cols)) {
x[[col]] <- x[[col]] %||% cols[[col]]
}
x %>% tidyr::replace_na(cols)
}
edges %>%
bind_rows(.id = "hash") %>%
filter(hash %in% edges_in_dag(edges, nodes)) %>%
tidyr::nest(-from) %>%
left_join(
nodes %>% node_frame() %>% select(from = hash, from_name = name),
by = "from"
) %>%
tidyr::unnest() %>%
tidyr::nest(-to) %>%
left_join(
nodes %>% node_frame() %>% select(to = hash, to_name = name),
by = "to"
) %>%
tidyr::unnest() %>%
select(hash, names(edges[[1]]), everything()) %>%
ensure_exists(angle = 0L, color = "black", lty = "solid", lineT = "thin") %>%
mutate(!!!dots)
}
edges_in_dag <- function(edges, nodes) {
if (!length(nodes) || !length(edges)) return(character())
all_edges <- bind_rows(edges) %>%
mutate(hash = names(edges)) %>%
tidyr::gather(position, node_hash, from:to)
edges_not_in_graph <- all_edges %>%
filter(!node_hash %in% nodes_in_dag(nodes))
setdiff(all_edges$hash, edges_not_in_graph$hash)
}
edge_edges <- function(edges, nodes, ...) {
do.call(edge, as.list(edge_frame(edges, nodes, ...)))
}
edge_exists <- function(edges, from_hash = NULL, to_hash = NULL) {
if (purrr::some(list(from_hash, to_hash), is.null)) return(FALSE)
edges %>%
purrr::keep(~ .$from %in% from_hash) %>%
purrr::keep(~ .$to %in% to_hash) %>%
length() %>%
`>`(0)
}
edge_points <- function(edges, nodes, push_by = 0) {
dag_edges <- edges_in_dag(edges, nodes)
if (!length(dag_edges)) return(tibble())
edge_frame(edges, nodes) %>%
tidyr::nest(-from) %>%
left_join(
nodes %>% node_frame() %>% select(from = hash, from.x = x, from.y = y),
by = "from"
) %>%
tidyr::unnest() %>%
tidyr::nest(-to) %>%
left_join(
nodes %>% node_frame() %>% select(to = hash, to.x = x, to.y = y),
by = "to"
) %>%
tidyr::unnest() %>%
select(hash, names(edges[[1]]), everything()) %>%
mutate(
d_x = to.x - from.x,
d_y = to.y - from.y,
from.x = from.x + push_by * d_x,
from.y = from.y + push_by * d_y,
to.x = to.x - push_by * d_x,
to.y = to.y - push_by * d_y,
color = if_else(color == "", "Black", color)
) %>%
select(-d_x, -d_y)
}
edge_toggle <- function(edges, from_hash, to_hash) {
existing <-
edges %>%
purrr::keep(~ .$from == from_hash) %>%
purrr::keep(~ .$to == to_hash)
if (length(existing)) {
for (edge_key in names(existing)) {
edges[[edge_key]] <- NULL
}
} else {
edges[[edge_key(from_hash, to_hash)]] <- list(from = from_hash, to = to_hash)
}
edges
}

View file

@ -0,0 +1,41 @@
# A fancy selectizeInput for angles
selectDegree <- function(
inputId,
label = "Degree",
min = -180 + by,
max = 180,
by = 45,
value = 0,
...
) {
if (sign(min + (max - min)) != sign(by)) {
by <- -by
}
choices <- seq(min, max, by)
selectizeInput(inputId, label = label, choices, selected = value, multiple = FALSE, ..., )
}
# A button group that toggles state and optionally allows one button to be active at a time
buttonGroup <- function(inputId, options, btn_class = "btn-default", multiple = FALSE, aria_label = NULL) {
btn_class <- paste("btn", paste(btn_class, collapse = " "))
button_list <- purrr::imap(options, button_in_group, class = btn_class)
selected <- shiny::restoreInput(inputId, default = "")
tagList(
singleton(tags$head(tags$script(src = "shinythingsButtonGroup.js"))),
tags$div(
class = "shinythings-btn-group btn-group",
id = inputId,
`data-input-id` = inputId,
`data-active` = selected,
`data-multiple` = as.integer(multiple),
role = "group",
button_list
)
)
}
button_in_group <- function(input_id, text, class = "btn btn-default") {
tags$button(id = input_id, class = class, text)
}

View file

@ -0,0 +1,310 @@
clickpad_UI <- function(id, ...) {
library(plotly)
ns <- NS(id)
tagList(
plotlyOutput(ns("plot"), ...)
)
}
clickpad_debug <- function(id, relayout = TRUE, doubleclick = TRUE, selected = FALSE, clickannotation = TRUE) {
ns <- NS(id)
col_width <- 12 / sum(relayout, doubleclick, selected, clickannotation)
tagList(
fluidRow(
style = "overflow-y: scroll; max-height: 200px;",
if (relayout) column(
col_width,
tags$p(tags$code("plotly_relayout")),
verbatimTextOutput(ns("v_relayout"))
),
if (doubleclick) column(
col_width,
tags$p(tags$code("plotly_doubleclick")),
verbatimTextOutput(ns("v_doubleclick"))
),
if (selected) column(
col_width,
tags$p(tags$code("plotly_selected")),
verbatimTextOutput(ns("v_selected"))
),
if (clickannotation) column(
col_width,
tags$p(tags$code("plotly_clickannotation")),
verbatimTextOutput(ns("v_clickannotation"))
)
)
)
}
clickpad <- function(
input, output, session,
nodes, edges,
plotly_source = "clickpad"
) {
library(plotly)
ns <- session$ns
node_primary <- reactive({ node_parent(nodes()) })
node_secondary <- reactive({ node_child(nodes()) })
node_is_adjusted <- reactive({ node_adjusted(nodes()) })
node_exposure <- reactive({ names(node_with_attribute(nodes(), "exposure")) })
node_outcome <- reactive({ names(node_with_attribute(nodes(), "outcome")) })
output$v_relayout <- renderPrint({
str(event_data("plotly_relayout", priority = "event", source = plotly_source))
})
output$v_doubleclick <- renderPrint({
str(event_data("plotly_doubleclick", priority = "event", source = plotly_source))
})
output$v_selected <- renderPrint({
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
})
output$v_clickannotation <- renderPrint({
str(event_data("plotly_clickannotation", priority = "event", source = plotly_source))
})
arrow_path <- function(from.x, from.y, to.x, to.y, dist = 0.2, ...) {
# angle of the line between `from` and `to`
theta <- atan2(to.y - from.y, to.x - from.x)
# push line starting/ending points away from node by a fixed distance
path_points = list(
x0 = from.x + dist * cos(theta),
y0 = from.y + dist * sin(theta),
x1 = to.x - dist * cos(theta),
y1 = to.y - dist * sin(theta)
)
# Find points for corners of arrow head (third point is `to`)
arrow_anchor_x = path_points$x1 - dist * cos(theta)
arrow_anchor_y = path_points$y1 - dist * sin(theta)
ad <- 0.1 * dist / tan(1/6 * pi)
path_points$a1_x = arrow_anchor_x + ad * cos(theta + 1/2 * pi)
path_points$a1_y = arrow_anchor_y + ad * sin(theta + 1/2 * pi)
path_points$a2_x = arrow_anchor_x - ad * cos(theta + 1/2 * pi)
path_points$a2_y = arrow_anchor_y - ad * sin(theta + 1/2 * pi)
# Draw arrow head in SVG path notation
as.character(glue::glue_data(
path_points,
"M{x0},{y0} L{x1},{y1} L{a1_x},{a1_y} L{a2_x},{a2_y} L{x1},{y1}"
))
}
arrows <- reactive({
if (is.null(edges()) || length(edges()) == 0) return(NULL)
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
ep <- edge_points(edges(), nodes())
if (!nrow(ep)) return(NULL)
ep %>%
purrr::pmap_chr(arrow_path, dist = 0.2) %>%
purrr::map(~ list(
type = "path",
line = list(color = "#000", width = 1),
fillcolor = "#000",
path = .x,
opacity = 0.75
))
})
create_node_annotations <- function(x, y, name, hash, ...) {
set_color <- function(
default, not_in_dag = NULL,
primary = NULL, secondary = NULL,
exposure = NULL, outcome = NULL, adjusted = NULL,
apply_order = c("primary", "not_in_dag", "adjusted", "exposure", "outcome", "secondary")
) {
applicable_states <- c(
"primary" = !is.null(node_primary()) && hash %in% node_primary(),
"secondary" = !is.null(node_secondary()) && hash %in% node_secondary(),
"adjusted" = !is.null(node_is_adjusted()) && hash %in% node_is_adjusted(),
"exposure" = !is.null(node_exposure()) && hash %in% node_exposure(),
"outcome" = !is.null(node_outcome()) && hash %in% node_outcome(),
"not_in_dag" = x < 0
)
applicable_states <- applicable_states[applicable_states]
if (!length(applicable_states)) return(default)
applicable_states <- applicable_states[apply_order]
applicable_states <- applicable_states[!is.na(applicable_states)]
if (!length(applicable_states)) return(default)
color <- switch(
names(applicable_states)[1],
primary = primary,
secondary = secondary,
adjusted = adjusted,
outcome = outcome,
exposure = exposure,
not_in_dag = not_in_dag,
default
)
color %||% default
}
background_color <- set_color(
default = "rgba(255, 255, 255, 0.5)",
not_in_dag = "#FDFDFD",
primary = "rgba(246, 227, 209, 0.75)"
)
font_color <- set_color(
default = "#000000",
not_in_dag = "#666666",
primary = "#D3751C",
exposure = "#418c7a",
outcome = "#ba2d0b",
apply_order = c("not_in_dag", "exposure", "outcome", "primary")
)
border_color <- set_color(
default = "#EDEDED",
not_in_dag = "#AAAAAA",
primary = list(NULL),
adjusted = "#1c2d3f",
apply_order = c("not_in_dag", "adjusted", "primary")
)
list(text = name,
node_hash = hash,
x = x,
y = y,
font = list(size = 24, color = font_color),
showarrow = FALSE,
align = "center",
captureevents = TRUE,
textposition = "middle center",
bordercolor = border_color,
bgcolor = background_color,
borderpad = 4)
}
annotations <- reactive({
if (is.null(nodes()) || length(nodes()) == 0) return(NULL)
node_frame(nodes(), full = TRUE) %>%
purrr::pmap(create_node_annotations)
})
left_margin <- list(
type = "rect",
line = list(color = "#AAAAAA", width = 1),
fillcolor = "#EEEEEE",
x0 = -100,
y0 = -100,
x1 = 0,
y1 = 100
)
output$plot <- renderPlotly({
debug_line("rendering clickpad")
redraw_plot()
ax <- list(
title = "",
zeroline = FALSE,
showline = FALSE,
showticklabels = FALSE,
showgrid = TRUE,
range = list(-1.5, 12.5)
)
ay <- ax
y_min <- purrr::map_dbl(nodes(), "y") %>% min()
y_max <- purrr::map_dbl(nodes(), "y") %>% max()
ay$range <- list(min(0.5, y_min), max(7.5, y_max))
p <- plot_ly(type = "scatter", source = plotly_source)
p %>%
layout(
annotations = annotations(),
shapes = c(list(left_margin), arrows()),
xaxis = ax,
yaxis = ay
) %>%
config(
edits = list(
annotationPosition = TRUE
),
showAxisDragHandles = FALSE
# displayModeBar = FALSE
) %>%
plotly::event_register("plotly_click") %>%
plotly::event_register("plotly_doubleclick") %>%
plotly::event_register("plotly_selected") %>%
plotly::event_register("plotly_clickannotation") %>%
htmlwidgets::onRender("
function(el) {
el.on('plotly_hover', function(d) { console.log('Hover: ', d) });
el.on('plotly_click', function(d) { console.log('Click: ', d) });
el.on('plotly_selected', function(d) { console.log('Select: ', d) });
}
")
})
redraw_plot <- reactiveVal(Sys.time())
new_coords_lag <- list(hash = NA_character_, x = NA_real_, y = NA_real_)
new_locations <- reactive({
req(annotations())
## https://stackoverflow.com/questions/54990350/extract-xyz-coordinates-from-draggable-shape-in-plotly-ternary-r-shiny
event <- event_data("plotly_relayout", source = plotly_source)
if (!length(event)) return()
annot_event <- event[grepl("^annotations\\[\\d+\\]\\.[xy]$", names(event))]
annot_index <- sub(".+\\[(\\d+)\\].+", "\\1", names(annot_event)[1]) %>% as.integer()
if (is.na(annot_index) || !is.integer(annot_index)) return()
if (length(annotations()) <= annot_index) {
stop("An error occurred, unable to match plotly update to correct node")
}
node_hash <- annotations()[[annot_index + 1]]$node_hash
# cli::cat_line("event_name: ", names(event)[1])
# cli::cat_line("annot_index: ", annot_index)
# cli::cat_line("node_hash: ", node_hash)
req(!is.null(node_hash))
new_x <- annot_event[grepl("\\.x", names(annot_event))] %>% unlist() %>% unname()
new_x <- if (new_x > 0) round(new_x, 0) else new_x
new_y <- annot_event[grepl("\\.y", names(annot_event))] %>% unlist() %>% unname()
new_y <- if (new_x > 0) round(new_y, 0) else new_y
i_nodes <- isolate(nodes())
current_pos <- i_nodes[[node_hash]][c("x", "y")] %>% unlist() %>% unname()
new_coords <- list(
hash = node_hash,
x = new_x,
y = new_y
)
if (identical(c(new_coords$x, new_coords$y), current_pos)) {
# No change in current node position
return()
}
if (identical(new_coords, new_coords_lag)) {
# The plotly_redraw may not have been a result of annotation position change
return()
}
new_coords_lag <<- new_coords
# cli::cat_line("new_x: ", new_x)
# cli::cat_line("new_y: ", new_y)
new_coords
})
return(reactive(new_locations()))
}

View file

@ -0,0 +1,288 @@
# UI Function -------------------------------------------------------------
dagPreviewUI <- function(id, include_graph_downloads = TRUE, start_hidden = FALSE) {
ns <- shiny::NS(id)
class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12"
download_choices <- c(
"PDF" = "pdf",
"PNG" = "png",
"LaTeX TikZ" = "tikz"
)
if (include_graph_downloads) {
download_choices <- c(
download_choices,
"dagitty (R: RDS)" = "dag_dagitty",
"ggdag (R: RDS)" = "dag_tidy"
)
}
tagList(
fluidRow(
column(
width = 12,
align = "center",
shinyjs::hidden(tags$div(
id = ns("tikzOut-help"),
class="alert alert-danger",
role="alert",
HTML(
"<p>An error occurred while compiling the preview.",
"Are there syntax errors in your labels?</p>",
"<p>Note that using characters that are",
'<a href="https://en.wikibooks.org/wiki/LaTeX/Special_Characters" target="_blank">reserved',
'characters in LaTeX</a> syntax may cause issues. For example,',
"single <code>$</code> need to be escaped: <code>\\$</code>.</p>"
)
)),
tags$div(
class = "dag-preview-tikz",
shinycssloaders::withSpinner(uiOutput(ns("tikzOut")), color = "#C4C4C4", proxy.height = "400px")
)
)
),
fluidRow(
tags$div(
class = class_3_col,
tags$div(
id = ns("showPreviewContainer"),
prettySwitch(ns("showPreview"), "Preview DAG", status = "primary", fill = TRUE, value = !start_hidden)
)
),
tags$div(
class = class_3_col,
selectInput(
inputId = ns("downloadType"),
label = "Type of download",
choices = download_choices
),
uiOutput(ns("downloadType_helptext"))
),
tags$div(
class = paste(class_3_col, "dagpreview-download-ui"),
div(
class = "btn-group",
role = "group",
id = ns("download-buttons"),
downloadButton(ns("downloadButton"))
)
)
)
)
}
# Server Module -----------------------------------------------------------
# This module takes tikz code and creates DAG preview content and returns TRUE
# or FALSE value to track whether the preview is visible.
dagPreview <- function(
input, output, session,
session_dir,
tikz_code,
dag_dagitty = reactive(NULL),
dag_tidy = reactive(NULL),
has_edges = reactive(FALSE)
) {
ns <- session$ns
SESSION_TEMPDIR <- file.path(session_dir, sub("-$", "", ns("")))
tikz_cache_dir <- reactiveVal(NULL)
# Render tikz preview ----
observe({
req(input$showPreview)
tikz_lines <- tikz_code()
req(gsub("\\s", "", tikz_lines) != "")
debug_input(tikz_lines, ns("tikz_code"))
useLib <- "\\usetikzlibrary{matrix,arrows,decorations.pathmorphing}"
pkgs <- paste(buildUsepackage(pkg = list("tikz"), uselibrary = useLib), collapse = "\n")
tex_dir <-
tex_cached_preview(
session_dir = SESSION_TEMPDIR,
obj = tikz_lines,
stem = "DAGimage",
imgFormat = "png",
returnType = "shiny",
density = tex_opts$get("density"),
keep_pdf = TRUE,
usrPackages = pkgs,
margin = tex_opts$get("margin"),
cleanup = tex_opts$get("cleanup")
)
tikz_cache_dir(tex_dir)
}, priority = -100)
# Create tikz preview UI ----
output$tikzOut <- renderUI({
req(input$showPreview)
shiny::validate(
shiny::need(
tryCatch({tikz_code(); TRUE}, error = function(e) FALSE) ||
tryCatch(gsub("\\s", "", tikz_code()), error = function(e) "") != "",
paste(
"Nothing to see here... yet. Please use the Sketch tab to create",
"and layout a DAG."
)
)
)
if (is.null(tikz_cache_dir())) return()
if (!length(tikz_cache_dir())) {
shinyjs::show("tikzOut-help")
return()
} else {
shinyjs::hide("tikzOut-help")
}
image_path <- file.path(tikz_cache_dir(), "DAGimage.png")
if (!file.exists(image_path)) {
debug_line("Image does not exist: ", image_path)
return()
}
image_tmp <- tempfile("dag_image_", SESSION_TEMPDIR, ".png")
file.copy(image_path, image_tmp)
debug_line("Serving image: ", image_tmp)
tags$img(
src = sub("www/", "", image_tmp, fixed = TRUE),
contentType = "image/png",
style = "max-width: 100%; max-height: 600px; -o-object-fit: contain;",
alt = "DAG"
)
})
output$downloadType_helptext <- renderUI({
is_tikz_download <- input$downloadType %in% c("pdf", "png", "tikz")
if (is_tikz_download && !input$showPreview) {
shinyjs::disable("downloadButton")
return(helpText("Please preview DAG to enable downloads"))
}
if (!is_tikz_download && !has_edges()) {
shinyjs::disable("downloadButton")
return(helpText("Please add at least one edge to the DAG"))
}
if (!length(tikz_cache_dir())) {
shinyjs::disable("downloadButton")
return()
}
shinyjs::enable("downloadButton")
})
output$downloadButton <- downloadHandler(
filename = function() {
paste0(
"DAG.",
switch(
input$downloadType,
"dagitty" =,
"ggdag" = "rds",
"tikz" = "tex",
"png" = "png",
"pdf" = "pdf"
)
)
},
content = function(file) {
if (input$downloadType == "pdf") {
file.copy(file.path(tikz_cache_dir(), "DAGimageDoc.pdf"), file)
} else if (input$downloadType == "png") {
file.copy(file.path(tikz_cache_dir(), "DAGimage.png"), file)
} else if (input$downloadType == "tikz") {
merge_tex_files(
file.path(tikz_cache_dir(), "DAGimageDoc.tex"),
file.path(tikz_cache_dir(), "DAGimage.tex"),
file
)
} else if (input$downloadType == "dag_dagitty") {
if (is.null(dag_dagitty())) return(NULL)
saveRDS(dag_dagitty(), file = file)
} else if (input$downloadType == "dag_tidy") {
if (is.null(dag_tidy())) return(NULL)
saveRDS(dag_tidy(), file = file)
}
},
contentType = NA
)
return(reactive(input$showPreview))
}
# Helper Functions --------------------------------------------------------
tex_cached_preview <- function(session_dir, ...) {
# Takes arguments for texPreview() except for fileDir
# hashes inputs and then writes preview into session_dir/args_hash
# Skips rendering if the cache already exists
# Returns directory containing the preview documents
args <- list(...)
args_hash <- digest::digest(args)
session_token <- basename(dirname(session_dir))
error_file <- paste0(session_token, "_", args_hash, ".tex")
cache_dir <- file.path(session_dir, args_hash)
error_dir <- file.path("www", "errors")
if (dir.exists(cache_dir)) {
return(cache_dir)
} else {
if (file.exists(file.path(error_dir, error_file))) {
# we already know that this tikz code won't work
warning("Bad tikz is still bad: ", error_file)
return(character())
}
}
dir.create(cache_dir, recursive = TRUE)
args$fileDir <- cache_dir
tryCatch({
do.call("texPreview", args)
cache_dir
}, error = function(e) {
# write bad tex code to disk
dir.create(error_dir, showWarnings = FALSE)
cat(
args$obj,
sep = "\n",
file = file.path(error_dir, error_file)
)
unlink(cache_dir, recursive = TRUE)
character()
})
}
# Merge tikz TeX source into main TeX file
merge_tex_files <- function(main_file, input_file, out_file) {
x <- readLines(main_file)
y <- readLines(input_file)
which_line <- grep("input{", x, fixed = TRUE)
which_line <- intersect(which_line, grep(basename(input_file), x))
x[which_line] <- paste(y, collapse = "\n")
writeLines(x, out_file)
}

View file

@ -0,0 +1,133 @@
add_slug <- function(ex) {
ex %>%
purrr::map(~ {
.x$slug <- gsub("[.]rds$", "", .x$file, ignore.case = TRUE)
.x
})
}
keep_ex_with_file <- function(ex) {
ex %>%
purrr::keep(~ file.exists(.$file))
}
nullify_missing <- function(ex, field = "image") {
ex %>%
purrr::modify_depth(
.depth = 1,
~ purrr::modify_at(., field, ~ {
if (!file.exists(.x)) list(NULL) else .x
})
)
}
full_path <- function(ex, field, path = file.path("www", "examples")) {
ex %>%
purrr::modify_depth(
.depth = 1,
~ purrr::modify_at(., field, ~ file.path(path, .x))
)
}
rel_path <- function(ex, field, path = file.path("www/")) {
ex %>%
purrr::modify_depth(
.depth = 1,
~ purrr::modify_at(., field, ~ if (!is.null(.x)) sub(path, "", .x, fixed = TRUE) else list(NULL))
)
}
load_example_values <- function(ex) {
purrr::map(ex, ~ {
values <- readRDS(.x$file)
.x$values <- list()
.x$values$nodes <- values$rvn$nodes
.x$values$edges <- values$rve$edges
.x
})
}
load_examples <- function(path = file.path("www", "examples")) {
ex_yaml <- file.path(path, "examples.yml")
if (!file.exists(ex_yaml)) {
stop("Unable to locate ", ex_yaml)
}
ex <- yaml::read_yaml(ex_yaml)
ex %>%
add_slug() %>%
full_path("image", path) %>%
full_path("file", path) %>%
keep_ex_with_file() %>%
nullify_missing("image") %>%
rel_path("image") %>%
load_example_values()
}
EXAMPLES <- load_examples()
examples_UI <- function(id) {
ns <- NS(id)
make_examples_ui <- function(name, description, slug, image = NULL, ...) {
tagList(
tags$h3(name),
if (!is.null(image)) tags$div(
class = "example-image",
tags$img(src = image)
),
tags$p(
HTML(description)
),
actionButton(ns(slug), "Load Example")
)
}
tagList(
EXAMPLES %>%
purrr::map(`[`, c("name", "description", "slug", "image")) %>%
purrr::map(~ purrr::pmap(.x, make_examples_ui))
)
}
examples <- function(input, output, session) {
input_ids <- EXAMPLES %>% purrr::map_chr("slug")
values <- EXAMPLES %>% purrr::map("values")
names(values) <- input_ids
lagged_value <- setNames(rep(0L, length(input_ids)), input_ids)
example_value <- reactiveVal(NULL)
observe({
current_btn_vals <- purrr::map_int(input_ids, ~ input[[.x]])
req(any(current_btn_vals > 0L))
# cli::cat_line("lagged: ", lagged_value)
# cli::cat_line("current: ", current_btn_vals)
idx <- which(current_btn_vals != lagged_value)
lagged_value <<- current_btn_vals
if (!length(idx)) {
example_value(NULL)
return(NULL)
}
changed_input <- input_ids[idx]
example_value(values[[changed_input]])
})
return(reactive(example_value()))
}
# ui <- fluidPage(
# examples_UI("example")
# )
# server <- function(input, output, session){
# callModule(examples, 'example')
# }
# shinyApp(ui, server)

View file

@ -0,0 +1,289 @@
# ---- Node Helper Functions ----
node_new <- function(nodes, hash, name, gap_y = 0.75, min_y = 1) {
# new nodes are added into the clickpad area but with x = -0.75
# need to check if there are other nodes in the holding space and adjust y
taken_y <- nodes %>% purrr::keep(~ !is.na(.$y)) %>% purrr::map_dbl(`[[`, "y")
new_y <- find_new_y(taken_y, gap_y, min_y)
nodes[[hash]] <- list(name = name, x = -0.75, y = new_y)
nodes
}
find_new_y <- function(y, gap_y = 0.75, min_y = 0.5) {
if (!length(y)) return(min_y)
if (min(y) >= (min_y + gap_y)) return(min_y)
if (length(y) == 1) return(y + gap_y)
y <- sort(y)
gap_size <- c(lead(y) - y)[-length(y)]
if (any(gap_size >= 2 * gap_y)) {
first_gap <- which(gap_size > 2 * gap_y)[1]
return(y[first_gap] + gap_y)
}
max(y) + gap_y
}
node_name_valid <- function(nodes, name, warn = FALSE) {
if (!nzchar(name)) {
warnNotification("Please specify a name for the node")
return(FALSE)
}
name_in_nodes <- vapply(nodes, function(n) name == n$name, FALSE)
if (any(name_in_nodes)) {
if (warn) warnNotification('"', name, '" is already the name of a node')
FALSE
} else {
TRUE
}
}
node_names <- function(nodes, all = FALSE) {
if (!length(nodes)) {
return(character())
}
x <- invertNames(sapply(nodes, function(x) x$name))
if (all) {
return(x)
}
in_dag <- sapply(nodes, function(n) n$x >= 0)
x[in_dag]
}
node_name_from_hash <- function(nodes, hash) {
invertNames(node_names(nodes))[hash]
}
node_update <- function(nodes, hash, name = NULL, x = NULL, y = NULL, name_latex = NULL) {
# in general update a property if arg is not null, default to current value
nodes[[hash]]$name <- name %||% nodes[[hash]]$name
nodes[[hash]]$x <- x %||% nodes[[hash]]$x
nodes[[hash]]$y <- y %||% nodes[[hash]]$y
# for name_latex precedence is arg > name (arg) > existing > name (existing)
nodes[[hash]]$name_latex <- name_latex %||% (
(name %??% name) %>% escape_quotes() %>% escape_latex()
) %||% nodes[[hash]]$name_latex %||% (
(nodes[[hash]]$name %??% nodes[[hash]]$name) %>% escape_quotes() %>% escape_latex()
)
nodes
}
node_set_attribute <- function(nodes, hash, attribs) {
for (node in names(nodes)) {
for (attrib in attribs) {
nodes[[node]][[attrib]] <- node %in% hash
}
}
nodes
}
node_unset_attribute <- function(nodes, hashes, attribs) {
for (hash in hashes) {
for (attrib in attribs) {
nodes[[hash]][[attrib]] <- FALSE
}
}
nodes
}
node_with_attribute <- function(nodes, attrib) {
if (length(nodes) == 0) return(NULL)
n <- nodes %>%
purrr::map(attrib) %>%
purrr::keep(isTRUE)
if (length(n)) n
}
node_parent <- function(nodes) {
names(node_with_attribute(nodes, "parent"))
}
node_child <- function(nodes) {
names(node_with_attribute(nodes, "child"))
}
node_adjusted <- function(nodes) {
names(node_with_attribute(nodes, "adjusted"))
}
node_delete <- function(nodes, hash) {
.nodes <- nodes[setdiff(names(nodes), hash)]
if (length(.nodes)) .nodes else list()
}
node_frame <- function(nodes, full = FALSE) {
if (!length(nodes)) {
return(tibble())
}
x <- bind_rows(nodes) %>%
mutate(hash = names(nodes)) %>%
select(hash, everything()) %>%
mutate(visible = !is.na(x), in_dag = x > 0) %>%
node_frame_complete()
if (full) {
return(x)
}
filter(x, in_dag)
}
node_frame_complete <- function(nodes) {
nodes$adjusted <- nodes[["adjusted"]] %||% FALSE
nodes$color_draw <- nodes[["color_draw"]] %||% "Black"
nodes$color_fill <- nodes[["color_fill"]] %||% "White"
nodes$color_text <- nodes[["color_text"]] %||% "Black"
nodes
}
node_vertices <- function(nodes) {
v_df <- node_frame(nodes)
vertices(
name = v_df$name,
x = v_df$x,
y = v_df$y,
hash = v_df$hash
)
}
node_nearest <- function(nodes, coordinfo, threshold = 0.5) {
nodes %>%
node_frame() %>%
mutate(dist = (x - coordinfo$x)^2 + (y - coordinfo$y)^2) %>%
arrange(dist) %>%
filter(dist <= threshold) %>%
slice(1) %>%
select(-dist)
}
nodes_in_dag <- function(nodes, include_staged = FALSE) {
n <- nodes %>%
purrr::keep(~ !is.na(.$x))
if (!include_staged) {
n <- purrr::keep(n, ~ .$x > 0)
}
names(n)
}
node_btn_id <- function(node_hash) paste0("node_toggle_", node_hash)
node_btn_get_hash <- function(node_btn_id) sub("node_toggle_", "", node_btn_id, fixed = TRUE)
node_tikz_style <- function(hash, adjusted, color_draw, color_fill, color_text, ...) {
# B/.style={fill=DarkRed, text=White}
if (!adjusted && color_fill == "White" && color_text == "Black") {
return(NA_character_)
}
style <-
list(
draw = if (adjusted) color_draw,
fill = color_fill,
text = color_text
) %>%
purrr::compact() %>%
purrr::imap_chr(~ glue::glue("{.y}={.x}")) %>%
paste(collapse = ", ")
glue::glue("{hash}/.style={{{style}}}")
}
node_frame_add_style <- function(nodes) {
if (!"name_latex" %in% names(nodes)) nodes$name_latex <- ""
nodes %>%
mutate(
tikz_style = purrr::pmap_chr(nodes, node_tikz_style),
name_latex = case_when(
is.na(name_latex) | name_latex == "" ~ escape_latex(name),
TRUE ~ name_latex
),
tikz_node = case_when(
!is.na(tikz_style) ~ paste(glue::glue("|[{hash}]| {name_latex}")),
TRUE ~ name_latex
)
)
}
escape_quotes <- function(x) {
x %??% gsub("(['\"])", "\\\\\\1", x)
}
escape_latex <- function(x, force = FALSE) {
if (is.null(x)) return(NULL)
if (!force && grepl("$", x, fixed = TRUE)) {
# has at least one dollar sign so we'll try to parse out the math
x_math <- chunk_math(x)
is_math <- attr(x_math, "is_math")
if (is.null(is_math) || !any(is_math)) {
# no math, just escape the original string
return(escape_latex(x, force = TRUE))
}
x_math[!is_math] <- x_math[!is_math] %>%
purrr::map_chr(escape_latex, force = TRUE)
return(paste0(x_math, collapse = ""))
}
## escape: # $ % ^ & _ { }
## replace: ~ -> \~{}
## replace: \ -> \textbackslash
## replace: < > -> \textless \textgreater
x <- gsub("\\", "\\textbackslash ", x, fixed = TRUE)
x <- gsub("<", "\\textless ", x, fixed = TRUE)
x <- gsub(">", "\\textgreater ", x, fixed = TRUE)
x <- gsub("([#$%^&_{}])", "\\\\\\1", x)
x <- gsub("~", "\\~{}", x, fixed = TRUE)
x
}
chunk_math <- function(x) {
x_s <- strsplit(x, character())[[1]]
idx <- which(grepl("$", x_s, fixed = TRUE))
if (!length(idx)) {
return(x)
}
# remove \\$ pairs from indexes
idx_has_escape <- which(grepl("\\", x_s[idx[idx > 1L] - 1L], fixed = TRUE))
if (length(idx_has_escape)) {
idx <- idx[-(idx_has_escape + as.integer(any(idx == 1)))]
}
# only include $ that touch at least one alphanum character
x_around_dollar <- purrr::map_chr(idx, ~ {
substr(x, max(0, .x - 1, na.rm = TRUE), min(nchar(x), .x + 1))
})
idx_no_adjacent_alpha <- which(!grepl("[[:alnum:]+=*{}.-]", x_around_dollar))
if (length(idx_no_adjacent_alpha)) {
idx <- idx[-idx_no_adjacent_alpha]
}
if (!length(idx)) {
return(x)
}
# finally, find the math chunks
chunks <- c()
is_math <- c()
i <- 1L
while (i < length(idx)) {
# idx[i - 1] ... idx[i]-1 -> not math
# idx[i]...idx[i+1] -> math
# skip ahead to idx[i + 2]
idx_not_math <- max(idx[i-1], 0, na.rm = TRUE)
chunks <- c(
chunks,
if (idx_not_math != idx[i] - 1L) substr(x, idx_not_math, idx[i] - 1L),
substr(x, idx[i], idx[i + 1]),
if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) {
substr(x, idx[i + 1] + 1, nchar(x))
}
)
is_math <- c(
is_math,
if (idx_not_math != idx[i] - 1L) FALSE,
TRUE,
if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) FALSE
)
i <- i + 2L
}
attributes(chunks)$is_math <- is_math
chunks
}

View file

@ -0,0 +1,37 @@
source("../node.R")
latex_text <- list(
list(t = "$m^2$", e = "$m^2$"),
list(t = "a $m^2$", e = "a $m^2$"),
list(t = "$m^2$ b", e = "$m^2$ b"),
list(t = "a $m^2$ b", e = "a $m^2$ b"),
list(t = "a $e=$$m^2$ b", e = "a $e=$$m^2$ b"),
list(t = "a $$ math", e = "a \\$\\$ math"),
list(t = "\\textbackslash", e = "\\textbackslash textbackslash"),
list(t = "# of", e = "\\# of"),
list(t = "$ amount", e = "\\$ amount"),
list(t = "my $$ is", e = "my \\$\\$ is"),
list(t = "$m $$ m$", e = "$m $$ m$"),
list(t = "$$ is $mc^2$", e = "\\$\\$ is $mc^2$"),
list(t = "a > b", e = "a \\textgreater b"), #<< extra space before b
list(t = "a < b", e = "a \\textless b"), #<< same
list(t = "a % b", e = "a \\% b"),
list(t = "a_b", e = "a\\_b"),
list(t = "a & b", e = "a \\& b"),
list(t = "a & b \\ c", e = "a \\& b \\textbackslash c"), #<< + space
list(t = "{a}", e = "\\{a\\}"),
list(t = "a ~ b", e = "a \\~{} b")
)
passed_test <- purrr::map_lgl(latex_text, function(x) {
identical(escape_latex(x$t), x$e)
})
if (all(passed_test)) {
cat('\nAll (', sum(passed_test), ') tests passed!', sep = '')
} else {
cat('\nThere were', sum(!passed_test), "failures...")
purrr::walk(latex_text[!passed_test], function(x) {
cat("\n'", x$t, "' returned '", escape_latex(x$t), "' not '", x$e, "'", sep = "")
})
}

View file

@ -0,0 +1,81 @@
# xcolors list ----
if (!file.exists(file.path("data", "xcolors.csv"))) {
if (!dir.exists('data')) {
stop("Not sure where I am")
}
message("Getting xcolors color list")
read_gz <- function(x) readLines(gzcon(url(x)))
xcolors <-
list(
# x11 = "http://www.ukern.de/tex/xcolor/tex/x11nam.def.gz",
svg = "http://www.ukern.de/tex/xcolor/tex/svgnam.def.gz"
) %>%
purrr::map(read_gz) %>%
purrr::flatten_chr() %>%
stringr::str_subset("^(%%|\\\\| )", negate = TRUE) %>%
stringr::str_remove("(;%|\\})$") %>%
readr::read_csv(col_names = c("color", "r", "g", "b")) %>%
arrange(color) %>%
readr::write_csv(file.path("data", "xcolors.csv"))
} else {
xcolors <-
file.path("data/xcolors.csv") %>%
read.csv(stringsAsFactors = FALSE)
}
# Color Functions ----
choose_dark_or_light <- function(x, black = "#000000", white = "#FFFFFF") {
# x = color_hex
color_rgb <- col2rgb(x)[, 1]
# from https://stackoverflow.com/a/3943023/2022615
color_rgb <- color_rgb / 255
color_rgb[color_rgb <= 0.03928] <- color_rgb[color_rgb <= 0.03928]/12.92
color_rgb[color_rgb > 0.03928] <- ((color_rgb[color_rgb > 0.03928] + 0.055)/1.055)^2.4
lum <- t(c(0.2126, 0.7152, 0.0722)) %*% color_rgb
if (lum[1, 1] > 0.179) eval(black) else eval(white)
}
xcolor_style <- function(hex, text, ...) {
glue::glue('background-color:{hex};color:{text}')
}
# Prep Color List ----
xcolors <-
xcolors %>%
mutate(
hex = rgb(r, g, b, maxColorValue = 1),
text = purrr::map_chr(hex, choose_dark_or_light)
) %>%
select(color, hex, text)
xcolors_list <- xcolors$color
names(xcolors_list) <- purrr::pmap_chr(xcolors, xcolor_style)
xcolor_label <- function(value) {
xcolors %>% filter(color == value) %>% purrr::pmap_chr(xcolor_style)
}
# xcolorPicker() ----
xcolorPicker <- function(inputId, label = NULL, selected = NULL, ...) {
selectizeInput(
inputId,
label = label,
choices = c("", xcolors_list),
multiple = FALSE,
selected = selected,
options = list(
searchField = "value",
render = I(
'{
item: (item, escape) => `<div>${escape(item.value)}</div>`,
option: (item, escape) => `<div style="${item.label};line-height: 2.5em">${escape(item.value)}</div>`
}'
))
)
}

View file

@ -0,0 +1,59 @@
# shinyDAG
shinyDAG is a web application that uses R and LaTeX to create publication-quality images of directed acyclic graphs (DAGs). Additionally, the application leverages complementary R packages to evaluate correlational structures and identify appropriate adjustment sets for estimating causal effects<sup>1-4</sup>. The web-based application can be accessed at [https://apps.gerkelab.com/shinyDAG/](https://apps.gerkelab.com/shinyDAG/).
## Key operations
### Adding nodes and edges
![Alt Text](Figures/AddNodeEdge.gif)
### Editing DAG aesthetics
![Alt Text](Figures/editEdge.gif)
## Examplary usage
The following DAG was reproduced from "A structural approach to selection bias"<sup>5</sup> (Figure 6A) using the shinyDAG web app.
![alt text](Figures/example1.png "Hernan Example")
For comparison, the DAG from the original article is shown below.
![alt text](Figures/example1_hernan.png "Hernan Original")
The DAG represents a study on the effects of antiretroviral therapy (E) on AIDS risk (D), where immunosuppression (U) is unmeasured. L represents presence of symptoms (such as fever, weight loss, and diarrhea) and C represents censoring. A spurious path exists between E and D due to selection bias. We can see this in shinyDAG by ensuring that we've selected E as the exposure, D as the outcome, adjusted for C, and then toggling the "Examine DAG elements" button in the bottom left corner. The spurious open path is displayed as D <- U -> L -> C <- E.
![alt text](Figures/paths.png "shinyDAG path output")
One possible resolution for this bias is to adjust for L. After toggling L in the "Select nodes to adjust" section, we see that all spurious E to D paths are now closed.
![alt text](Figures/paths2.png "shinyDAG final path output")
## Other features
In addition PDF and PNG exports, users can download R objects in `ggdag` or `daggity` formats, as well as the source LaTeX code. The "Edit LaTeX" pane permits in-app modification of the LaTeX code with a preview window; however, users should be aware that the information in "Examine DAG elements" is not responsive to changes in the Edit LaTeX pane.
shinyDAG should work in most modern web browsers, however, we have observed optimal performance in Chrome. The most notable difference across OS/browsers is likely to be in display handling for the PDF preview in the main panel: various user or browser-specific settings will determine the default zoom level.
## Citing shinyDAG
shinyDAG was developed by Jordan Creed, Garrick Aden-Buie and Travis Gerke.
Concept DOI: 10.5281/zenodo.1288712
v0.1.0 DOI: 10.5281/zenodo.1296477
v0.0.0 DOI: 10.5281/zenodo.1288713
## References
1. Richard Iannone (NA). DiagrammeR: Graph/Network Visualization. R package version 1.0.0.
[https://github.com/rich-iannone/DiagrammeR](https://github.com/rich-iannone/DiagrammeR).
1. Johannes Textor and Benito van der Zander (2016). dagitty: Graphical Analysis of Structural Causal
Models. R package version 0.2-2. [https://CRAN.R-project.org/package=dagitty](https://CRAN.R-project.org/package=dagitty).
1. Malcolm Barrett (2018). ggdag: Analyze and Create Elegant Directed Acyclic Graphs. R package
version 0.1.0. [https://CRAN.R-project.org/package=ggdag](https://CRAN.R-project.org/package=ggdag).
1. Csardi G, Nepusz T: The igraph software package for complex network research, InterJournal,
Complex Systems 1695. 2006. [http://igraph.org](http://igraph.org).
1. Hernan MA, Hernandez-Díaz S, Robins JM. A structural approach to selection bias. Epidemiology 2004;15:615-625.

View file

@ -0,0 +1 @@
1.0.0

View file

@ -0,0 +1,152 @@
color,r,g,b
AliceBlue,0.94,0.972,1
AntiqueWhite,0.98,0.92,0.844
Aqua,0,1,1
Aquamarine,0.498,1,0.83
Azure,0.94,1,1
Beige,0.96,0.96,0.864
Bisque,1,0.894,0.77
Black,0,0,0
BlanchedAlmond,1,0.92,0.804
Blue,0,0,1
BlueViolet,0.54,0.17,0.888
Brown,0.648,0.165,0.165
BurlyWood,0.87,0.72,0.53
CadetBlue,0.372,0.62,0.628
Chartreuse,0.498,1,0
Chocolate,0.824,0.41,0.116
Coral,1,0.498,0.312
CornflowerBlue,0.392,0.585,0.93
Cornsilk,1,0.972,0.864
Crimson,0.864,0.08,0.235
Cyan,0,1,1
DarkBlue,0,0,0.545
DarkCyan,0,0.545,0.545
DarkGoldenrod,0.72,0.525,0.044
DarkGray,0.664,0.664,0.664
DarkGreen,0,0.392,0
DarkGrey,0.664,0.664,0.664
DarkKhaki,0.74,0.716,0.42
DarkMagenta,0.545,0,0.545
DarkOliveGreen,0.332,0.42,0.185
DarkOrange,1,0.55,0
DarkOrchid,0.6,0.196,0.8
DarkRed,0.545,0,0
DarkSalmon,0.912,0.59,0.48
DarkSeaGreen,0.56,0.736,0.56
DarkSlateBlue,0.284,0.24,0.545
DarkSlateGray,0.185,0.31,0.31
DarkSlateGrey,0.185,0.31,0.31
DarkTurquoise,0,0.808,0.82
DarkViolet,0.58,0,0.828
DeepPink,1,0.08,0.576
DeepSkyBlue,0,0.75,1
DimGray,0.41,0.41,0.41
DimGrey,0.41,0.41,0.41
DodgerBlue,0.116,0.565,1
FireBrick,0.698,0.132,0.132
FloralWhite,1,0.98,0.94
ForestGreen,0.132,0.545,0.132
Fuchsia,1,0,1
Gainsboro,0.864,0.864,0.864
GhostWhite,0.972,0.972,1
Gold,1,0.844,0
Goldenrod,0.855,0.648,0.125
Gray,0.5,0.5,0.5
Green,0,0.5,0
GreenYellow,0.68,1,0.185
Grey,0.5,0.5,0.5
Honeydew,0.94,1,0.94
HotPink,1,0.41,0.705
IndianRed,0.804,0.36,0.36
Indigo,0.294,0,0.51
Ivory,1,1,0.94
Khaki,0.94,0.9,0.55
Lavender,0.9,0.9,0.98
LavenderBlush,1,0.94,0.96
LawnGreen,0.488,0.99,0
LemonChiffon,1,0.98,0.804
LightBlue,0.68,0.848,0.9
LightCoral,0.94,0.5,0.5
LightCyan,0.88,1,1
LightGoldenrod,0.933,0.867,0.51
LightGoldenrodYellow,0.98,0.98,0.824
LightGray,0.828,0.828,0.828
LightGreen,0.565,0.932,0.565
LightGrey,0.828,0.828,0.828
LightPink,1,0.712,0.756
LightSalmon,1,0.628,0.48
LightSeaGreen,0.125,0.698,0.668
LightSkyBlue,0.53,0.808,0.98
LightSlateBlue,0.518,0.44,1
LightSlateGray,0.468,0.532,0.6
LightSlateGrey,0.468,0.532,0.6
LightSteelBlue,0.69,0.77,0.87
LightYellow,1,1,0.88
Lime,0,1,0
LimeGreen,0.196,0.804,0.196
Linen,0.98,0.94,0.9
Magenta,1,0,1
Maroon,0.5,0,0
MediumAquamarine,0.4,0.804,0.668
MediumBlue,0,0,0.804
MediumOrchid,0.73,0.332,0.828
MediumPurple,0.576,0.44,0.86
MediumSeaGreen,0.235,0.7,0.444
MediumSlateBlue,0.484,0.408,0.932
MediumSpringGreen,0,0.98,0.604
MediumTurquoise,0.284,0.82,0.8
MediumVioletRed,0.78,0.084,0.52
MidnightBlue,0.098,0.098,0.44
MintCream,0.96,1,0.98
MistyRose,1,0.894,0.884
Moccasin,1,0.894,0.71
NavajoWhite,1,0.87,0.68
Navy,0,0,0.5
NavyBlue,0,0,0.5
OldLace,0.992,0.96,0.9
Olive,0.5,0.5,0
OliveDrab,0.42,0.556,0.136
Orange,1,0.648,0
OrangeRed,1,0.27,0
Orchid,0.855,0.44,0.84
PaleGoldenrod,0.932,0.91,0.668
PaleGreen,0.596,0.985,0.596
PaleTurquoise,0.688,0.932,0.932
PaleVioletRed,0.86,0.44,0.576
PapayaWhip,1,0.936,0.835
PeachPuff,1,0.855,0.725
Peru,0.804,0.52,0.248
Pink,1,0.752,0.796
Plum,0.868,0.628,0.868
PowderBlue,0.69,0.88,0.9
Purple,0.5,0,0.5
Red,1,0,0
RosyBrown,0.736,0.56,0.56
RoyalBlue,0.255,0.41,0.884
SaddleBrown,0.545,0.27,0.075
Salmon,0.98,0.5,0.448
SandyBrown,0.956,0.644,0.376
SeaGreen,0.18,0.545,0.34
Seashell,1,0.96,0.932
Sienna,0.628,0.32,0.176
Silver,0.752,0.752,0.752
SkyBlue,0.53,0.808,0.92
SlateBlue,0.415,0.352,0.804
SlateGray,0.44,0.5,0.565
SlateGrey,0.44,0.5,0.565
Snow,1,0.98,0.98
SpringGreen,0,1,0.498
SteelBlue,0.275,0.51,0.705
Tan,0.824,0.705,0.55
Teal,0,0.5,0.5
Thistle,0.848,0.75,0.848
Tomato,1,0.39,0.28
Turquoise,0.25,0.88,0.815
Violet,0.932,0.51,0.932
VioletRed,0.816,0.125,0.565
Wheat,0.96,0.87,0.7
White,1,1,1
WhiteSmoke,0.96,0.96,0.96
Yellow,1,1,0
YellowGreen,0.604,0.804,0.196
1 color r g b
2 AliceBlue 0.94 0.972 1
3 AntiqueWhite 0.98 0.92 0.844
4 Aqua 0 1 1
5 Aquamarine 0.498 1 0.83
6 Azure 0.94 1 1
7 Beige 0.96 0.96 0.864
8 Bisque 1 0.894 0.77
9 Black 0 0 0
10 BlanchedAlmond 1 0.92 0.804
11 Blue 0 0 1
12 BlueViolet 0.54 0.17 0.888
13 Brown 0.648 0.165 0.165
14 BurlyWood 0.87 0.72 0.53
15 CadetBlue 0.372 0.62 0.628
16 Chartreuse 0.498 1 0
17 Chocolate 0.824 0.41 0.116
18 Coral 1 0.498 0.312
19 CornflowerBlue 0.392 0.585 0.93
20 Cornsilk 1 0.972 0.864
21 Crimson 0.864 0.08 0.235
22 Cyan 0 1 1
23 DarkBlue 0 0 0.545
24 DarkCyan 0 0.545 0.545
25 DarkGoldenrod 0.72 0.525 0.044
26 DarkGray 0.664 0.664 0.664
27 DarkGreen 0 0.392 0
28 DarkGrey 0.664 0.664 0.664
29 DarkKhaki 0.74 0.716 0.42
30 DarkMagenta 0.545 0 0.545
31 DarkOliveGreen 0.332 0.42 0.185
32 DarkOrange 1 0.55 0
33 DarkOrchid 0.6 0.196 0.8
34 DarkRed 0.545 0 0
35 DarkSalmon 0.912 0.59 0.48
36 DarkSeaGreen 0.56 0.736 0.56
37 DarkSlateBlue 0.284 0.24 0.545
38 DarkSlateGray 0.185 0.31 0.31
39 DarkSlateGrey 0.185 0.31 0.31
40 DarkTurquoise 0 0.808 0.82
41 DarkViolet 0.58 0 0.828
42 DeepPink 1 0.08 0.576
43 DeepSkyBlue 0 0.75 1
44 DimGray 0.41 0.41 0.41
45 DimGrey 0.41 0.41 0.41
46 DodgerBlue 0.116 0.565 1
47 FireBrick 0.698 0.132 0.132
48 FloralWhite 1 0.98 0.94
49 ForestGreen 0.132 0.545 0.132
50 Fuchsia 1 0 1
51 Gainsboro 0.864 0.864 0.864
52 GhostWhite 0.972 0.972 1
53 Gold 1 0.844 0
54 Goldenrod 0.855 0.648 0.125
55 Gray 0.5 0.5 0.5
56 Green 0 0.5 0
57 GreenYellow 0.68 1 0.185
58 Grey 0.5 0.5 0.5
59 Honeydew 0.94 1 0.94
60 HotPink 1 0.41 0.705
61 IndianRed 0.804 0.36 0.36
62 Indigo 0.294 0 0.51
63 Ivory 1 1 0.94
64 Khaki 0.94 0.9 0.55
65 Lavender 0.9 0.9 0.98
66 LavenderBlush 1 0.94 0.96
67 LawnGreen 0.488 0.99 0
68 LemonChiffon 1 0.98 0.804
69 LightBlue 0.68 0.848 0.9
70 LightCoral 0.94 0.5 0.5
71 LightCyan 0.88 1 1
72 LightGoldenrod 0.933 0.867 0.51
73 LightGoldenrodYellow 0.98 0.98 0.824
74 LightGray 0.828 0.828 0.828
75 LightGreen 0.565 0.932 0.565
76 LightGrey 0.828 0.828 0.828
77 LightPink 1 0.712 0.756
78 LightSalmon 1 0.628 0.48
79 LightSeaGreen 0.125 0.698 0.668
80 LightSkyBlue 0.53 0.808 0.98
81 LightSlateBlue 0.518 0.44 1
82 LightSlateGray 0.468 0.532 0.6
83 LightSlateGrey 0.468 0.532 0.6
84 LightSteelBlue 0.69 0.77 0.87
85 LightYellow 1 1 0.88
86 Lime 0 1 0
87 LimeGreen 0.196 0.804 0.196
88 Linen 0.98 0.94 0.9
89 Magenta 1 0 1
90 Maroon 0.5 0 0
91 MediumAquamarine 0.4 0.804 0.668
92 MediumBlue 0 0 0.804
93 MediumOrchid 0.73 0.332 0.828
94 MediumPurple 0.576 0.44 0.86
95 MediumSeaGreen 0.235 0.7 0.444
96 MediumSlateBlue 0.484 0.408 0.932
97 MediumSpringGreen 0 0.98 0.604
98 MediumTurquoise 0.284 0.82 0.8
99 MediumVioletRed 0.78 0.084 0.52
100 MidnightBlue 0.098 0.098 0.44
101 MintCream 0.96 1 0.98
102 MistyRose 1 0.894 0.884
103 Moccasin 1 0.894 0.71
104 NavajoWhite 1 0.87 0.68
105 Navy 0 0 0.5
106 NavyBlue 0 0 0.5
107 OldLace 0.992 0.96 0.9
108 Olive 0.5 0.5 0
109 OliveDrab 0.42 0.556 0.136
110 Orange 1 0.648 0
111 OrangeRed 1 0.27 0
112 Orchid 0.855 0.44 0.84
113 PaleGoldenrod 0.932 0.91 0.668
114 PaleGreen 0.596 0.985 0.596
115 PaleTurquoise 0.688 0.932 0.932
116 PaleVioletRed 0.86 0.44 0.576
117 PapayaWhip 1 0.936 0.835
118 PeachPuff 1 0.855 0.725
119 Peru 0.804 0.52 0.248
120 Pink 1 0.752 0.796
121 Plum 0.868 0.628 0.868
122 PowderBlue 0.69 0.88 0.9
123 Purple 0.5 0 0.5
124 Red 1 0 0
125 RosyBrown 0.736 0.56 0.56
126 RoyalBlue 0.255 0.41 0.884
127 SaddleBrown 0.545 0.27 0.075
128 Salmon 0.98 0.5 0.448
129 SandyBrown 0.956 0.644 0.376
130 SeaGreen 0.18 0.545 0.34
131 Seashell 1 0.96 0.932
132 Sienna 0.628 0.32 0.176
133 Silver 0.752 0.752 0.752
134 SkyBlue 0.53 0.808 0.92
135 SlateBlue 0.415 0.352 0.804
136 SlateGray 0.44 0.5 0.565
137 SlateGrey 0.44 0.5 0.565
138 Snow 1 0.98 0.98
139 SpringGreen 0 1 0.498
140 SteelBlue 0.275 0.51 0.705
141 Tan 0.824 0.705 0.55
142 Teal 0 0.5 0.5
143 Thistle 0.848 0.75 0.848
144 Tomato 1 0.39 0.28
145 Turquoise 0.25 0.88 0.815
146 Violet 0.932 0.51 0.932
147 VioletRed 0.816 0.125 0.565
148 Wheat 0.96 0.87 0.7
149 White 1 1 1
150 WhiteSmoke 0.96 0.96 0.96
151 Yellow 1 1 0
152 YellowGreen 0.604 0.804 0.196

View file

@ -0,0 +1,95 @@
# shiny-verse:3.6.0
FROM rocker/verse:3.5.3
RUN apt-get update -qq && apt-get -y --no-install-recommends install \
libxml2-dev \
libcairo2-dev \
libsqlite3-dev \
libmariadbd-dev \
libmariadb-client-lgpl-dev \
libpq-dev \
libssl-dev \
libcurl4-openssl-dev \
libssh2-1-dev \
unixodbc-dev \
&& install2.r --error \
--deps TRUE \
tidyverse \
dplyr \
devtools \
formatR \
remotes \
selectr \
caTools \
BiocManager
LABEL maintainer="Travis Gerke (Travis.Gerke@moffitt.org)"
# Install system dependencies for required packages
RUN apt-get update -qq && apt-get -y --no-install-recommends install \
libssl-dev \
libxml2-dev \
libmagick++-dev \
libv8-3.14-dev \
libglu1-mesa-dev \
freeglut3-dev \
mesa-common-dev \
libudunits2-dev \
libpoppler-cpp-dev \
libwebp-dev \
&& apt-get clean \
&& rm -rf /var/lib/apt/lists/ \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error --deps TRUE \
shinyAce \
shinydashboard \
shinyWidgets \
DiagrammeR \
ggdag \
igraph \
pdftools \
shinyBS \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN Rscript -e "devtools::install_github('metrumresearchgroup/texPreview', ref = 'e954322')" \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
# Install TinyTeX
RUN install2.r --error tinytex \
&& export CTAN_REPO="http://mirror.las.iastate.edu/tex-archive/systems/texlive/tlnet" \
&& wget -qO- \
"https://github.com/yihui/tinytex/raw/master/tools/install-unx.sh" | \
sh -s - --admin --no-path \
&& mv ~/.TinyTeX /opt/TinyTeX \
&& /opt/TinyTeX/bin/*/tlmgr path add \
&& tlmgr update --self \
&& tlmgr install metafont mfware inconsolata tex ae parskip listings \
&& tlmgr install standalone varwidth xcolor colortbl multirow psnfss setspace pgf \
&& tlmgr path add \
&& Rscript -e "tinytex::r_texmf()" \
&& chown -R root:staff /opt/TinyTeX \
&& chmod -R a+w /opt/TinyTeX \
&& chmod -R a+wx /opt/TinyTeX/bin \
&& echo "PATH=${PATH}" >> /usr/local/lib/R/etc/Renviron \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error --deps TRUE shinyjs \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error plotly \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
RUN install2.r --error shinycssloaders \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
ARG TRIGGER_UPDATE=unknown
RUN installGithub.r gadenbuie/grkstyle r-lib/styler
RUN installGithub.r gadenbuie/shinyThings@undo \
&& rm -rf /tmp/downloaded_packages/ /tmp/*.rds
#ARG SHINY_APP_IDLE_TIMEOUT=600
#RUN sed -i "s/directory_index on;/app_idle_timeout ${SHINY_APP_IDLE_TIMEOUT};/g" /etc/shiny-server/shiny-server.conf
#COPY . /srv/shiny-server/shinyDAG
#RUN chown -R shiny:shiny /srv/shiny-server/

View file

@ -0,0 +1,36 @@
## Building and developing shinyDAG
### shinyDAG dev environment
I use the Dockerfile in this folder to create a fully-featured RStudio docker container that is *pretty close* to the final shinyDAG environment.
Note that it's not perfect and if you install packages into this container, you'll need to also update the main shinyDAG docker file [here](../Dockerfile).
To create the dev environment:
```bash
# make sure you're in the ./dev folder
cd dev
# make the dev image
docker build -t shinydag-dev .
# move back to shinyDAG proper and start up the dev image
cd ..
docker run --rm -p 8787:8787 -v $(pwd):/home/rstudio/shinydag -e PASSWORD="password" shinydag-dev
```
(Note that you should probably change the password above, but if you're only running locally it's not a big deal.)
Then navigate to <localhost:8787> and login using the password you entered.
### Create shinyDAG image
```bash
docker build -t gerkelab/shinydag:dev .
# To send up to docker hub
docker push
```
The `:dev` indicates that this image is tagged `dev`, but this can be anything you want.
If you don't add a tag, it's assumed to be `:latest` which is kind of like git's `master` but for docker containers.

View file

@ -0,0 +1,83 @@
library(shiny)
library(shinydashboard)
library(DiagrammeR)
library(dagitty)
library(igraph)
library(texPreview)
library(shinyAce)
library(shinyBS)
library(dplyr)
library(ggdag)
library(shinyWidgets)
library(shinyjs)
library(shinycssloaders)
library(shinyThings)
source("R/node.R")
source("R/edge.R")
source("R/columns.R")
source("R/module/clickpad.R")
source("R/module/dagPreview.R")
source("R/module/examples.R")
source("R/xcolorPicker.R")
source("R/aes_ui.R")
# Additional libraries: tidyr, digest, rlang
enableBookmarking(store = "server")
tex_opts$set(list(
density = 1200,
margin = list(left = 0, top = 0, right = 0, bottom = 0),
cleanup = c("aux", "log")
))
# Functions ---------------------------------------------------------------
DEBUG <- getOption("shinydag.debug", FALSE)
debug_input <- function(x, x_name = NULL) {
if (!isTRUE(DEBUG)) return()
if (is.null(x)) {
cat(if (!is.null(x_name)) paste0(x_name, ":"), "NULL", "\n")
} else if (inherits(x, "igraph")) {
cat(capture.output(print(x)), "", sep = "\n")
} else if (length(x) == 1 && !is.list(x)) {
cat(if (!is.null(x_name)) paste0(x_name, ":"), if (length(names(x))) names(x), "-", x, "\n")
} else if (is.list(x) && length(x) == 0) {
cat(if (!is.null(x_name)) paste0(x_name, ":"), "list()", "\n")
} else {
if (!inherits(x, "data.frame")) x <- tibble::enframe(x)
cat(if (!is.null(x_name)) paste0(x_name, ":"), knitr::kable(x), "", sep = "\n")
}
}
debug_line <- function(...) {
if (!isTRUE(DEBUG)) return()
cli::cat_line(...)
}
buildUsepackage <- if (length(find("build_usepackage"))) texPreview::build_usepackage else texPreview::buildUsepackage
# use y if x is.null
`%||%` <- function(x, y) if (is.null(x)) y else x
# use y if x is not null(ish) (otherwise NULL)
`%??%` <- function(x, y) if (!is.null(x) && x != "") y
warnNotification <- function(...) showNotification(
paste0(...), duration = 5, closeButton = TRUE, type = "warning"
)
invertNames <- function(x) setNames(names(x), unname(x))
# String utilities ----
str_and <- function(...) {
x <- c(...)
last <- if (length(x) > 2) ", and " else " and "
glue::glue_collapse(x, sep = ", ", last = last)
}
str_plural <- function(x, word, plural = paste0(word, "s")) {
if (length(x) > 1) plural else word
}

895
apps/shinyDAG-1.0.0/server.R Executable file
View file

@ -0,0 +1,895 @@
# Server ------------------------------------------------------------------
server <- function(input, output, session) {
# ---- Global - Session Temp Directory ----
SESSION_TEMPDIR <- file.path("www", session$token)
dir.create(SESSION_TEMPDIR, showWarnings = FALSE)
onStop(function() {
message("Removing session tempdir: ", SESSION_TEMPDIR)
unlink(SESSION_TEMPDIR, recursive = TRUE)
})
message("Using session tempdir: ", SESSION_TEMPDIR)
# ---- Global - Bookmarking ----
onBookmark(function(state) {
state$values$rvn <- list()
state$values$rvn$nodes <- rvn$nodes
state$values$rve <- list()
state$values$rve$edges <- rve$edges
state$values$query_string <- session$clientData$url_search
# Store outcome/exposure/adjust node selections
state$values$sel <- list(
exposureNode = input$exposureNode,
outcomeNode = input$outcomeNode,
adjustNode = input$adjustNode
)
})
onBookmarked(function(url) {
message("bookmark: ", url)
showBookmarkUrlModal(url)
updateQueryString(url)
})
onRestore(function(state) {
showModal(modalDialog(
title = NULL,
easyClose = FALSE,
footer = NULL,
tags$p(class = "text-center", "Loading your shinyDag workspace, please wait."),
tags$div(class = "gerkelab-spinner")
))
# clear selected node and text input to try to prevent existing values from
# changing the name of the node that gets selected on restore
rvn$nodes <- node_unset_attribute(rvn$nodes, names(rvn$nodes), "parent")
updateTextInput(session, "node_list_node_name", value = "")
if (isTRUE(getOption("shinydag.debug", FALSE))) {
names(state$values) %>%
purrr::set_names() %>%
purrr::map(~ state$values[[.]]) %>%
purrr::compact() %>%
purrr::iwalk(~ debug_input(.x, paste0("state$values$", .y)))
}
rvn$nodes <- state$values$rvn$nodes
rve$edges <- state$values$rve$edges
})
onRestored(function(state) {
removeModal()
updateSelectInput(session, "exposureNode", selected = state$values$sel$exposureNode)
updateSelectInput(session, "outcomeNode", selected = state$values$sel$outcomeNode)
updateSelectizeInput(session, "adjustNode", selected = state$values$sel$adjustNode)
})
# ---- Global - Reactive Values ----
rve <- reactiveValues(edges = list())
rvn <- reactiveValues(nodes = list())
# rve$edges is a named list, e.g. for hash(A) -> hash(B):
# rve$edges[edge_key(hash(A), hash(B))] = list(from = hash(A), to = hash(B))
# rvn$nodes is a named list where name is a hash
# rvn$nodes$abcdefg = list(name, x, y)
# ---- Sketch - Reactive Values Undo/Redo ----
rv_undo_state <- shinyThings::undoHistory(
id = "undo_rv",
value = reactive({
req(length(rvn$nodes) > 0)
node_params <- c("name", "x", "y", "parent", "exposure", "outcome", "adjusted")
nodes <- rvn$nodes %>%
purrr::map(`[`, node_params) %>%
purrr::map(purrr::compact)
edge_params <- c("from", "to")
edges <- rve$edges %>%
purrr::map(`[`, edge_params) %>%
purrr::map(purrr::compact)
list(
nodes = nodes,
edges = edges
)
})
)
observe({
req(!is.null(rv_undo_state()))
rv_state <- rv_undo_state()
debug_input(rv_state$nodes, "undo/redo - new nodes")
debug_input(rv_state$edges, "undo/redo - new edges")
rvn$nodes <- rv_state$nodes
rve$edges <- rv_state$edges
}, priority = 1000)
# ---- Sketch - Node Controls ----
node_btn_id <- function(node_hash) paste0("node_toggle_", node_hash)
node_btn_get_hash <- function(node_btn_id) sub("node_toggle_", "", node_btn_id, fixed = TRUE)
node_list_buttons_redraw <- reactiveVal(Sys.time())
node_list_node_is_new <- reactiveVal(FALSE)
node_list_selected_child <- reactive({ node_child(rvn$nodes) }) # TODO: remove
node_list_selected_node <- reactiveVal(NULL)
observe({
I("update selected node?")
# this feels hacky but on the one hand we want to be able to update the
# selected parent node just by updating rvn$nodes, and on the other we don't
# want to propagate a reactive change if the value stays the same. So this
# observer is kind of like a debouncer for node_list_selected_node()
current_selected_node <- isolate(node_list_selected_node())
new_selected_node <- node_parent(rvn$nodes)
if (!identical(current_selected_node, new_selected_node)) {
node_list_selected_node(new_selected_node)
}
})
# debug selected nodes
observe({
debug_input(node_list_selected_node(), "node_list_selected_node")
debug_input(node_list_selected_child(), "node_list_selected_child")
})
# Handle add node button, creates new node and sets focus
observeEvent(input$node_list_node_add, {
new_node_hash <- digest::digest(Sys.time())
rvn$nodes <- node_new(rvn$nodes, new_node_hash, "new node") %>%
node_set_attribute(new_node_hash, "parent")
node_list_buttons_redraw(Sys.time())
node_list_node_is_new(TRUE)
})
# Show, hide or update node name text input
observe({
I("show/hide/update node name text box")
if (is.null(node_list_selected_node())) {
shinyjs::hide("node_list_node_name_container")
return()
}
s_node_selected <- node_list_selected_node()
# Selected node already exists, update UI
shinyjs::show("node_list_node_name_container")
shinyjs::runjs("set_input_focus('node_list_node_name')")
s_node_name <- node_name_from_hash(isolate(rvn$nodes), s_node_selected)
if (isolate(node_list_node_is_new())) {
node_list_node_is_new(FALSE)
updateTextInput(session, "node_list_node_name", value = "", placeholder = "Enter Node Name")
} else {
updateTextInput(
session,
"node_list_node_name",
value = unname(s_node_name)
)
}
}, priority = 1000)
# Handle node name text input
node_name_text_input <- reactive({
input$node_list_node_name
})
observe({
I("update node name")
node_name_debounced <- debounce(node_name_text_input, 750)
node_name <- node_name_debounced()
debug_input(node_name, "node_list_node_name (debounced)")
s_node <- isolate(node_list_selected_node())
req(s_node, node_name != "")
rvn$nodes <- node_update(isolate(rvn$nodes), s_node, node_name)
}, priority = 2000)
# Show editing buttons when appropriate
observe({
I("toggle edit buttons")
if (is.null(node_list_selected_node()) || !length(rvn$nodes)) {
# no node selected, can only add a new node
shinyjs::hide("node_list_node_delete")
} else {
# can now delete any selected node
shinyjs::show("node_list_node_delete")
}
})
# Action: delete node
observeEvent(input$node_list_node_delete, {
# Remove node
node_to_delete <- node_list_selected_node()
rvn$nodes[[node_to_delete]] <- NULL
# Remove any edges
edges_with_node <- rve$edges %>%
purrr::keep(~ node_to_delete %in% c(.$from, .$to)) %>%
names()
if (length(edges_with_node)) rve$edges[edges_with_node] <- NULL
shinyjs::hide("node_list_node_name_container")
shinyjs::hide("node_list_node_delete")
})
# ---- Sketch - Help Text ----
output$node_list_helptext <- renderUI({
s_node <- node_list_selected_node()
no_nodes <- length(rvn$nodes) == 0
not_enough_nodes <- length(rvn$nodes) < 2
no_node_selected <- !no_nodes && is.null(s_node)
no_dag_nodes <- !no_nodes && length(nodes_in_dag(rvn$nodes)) == 0
not_enough_dag_nodes <- !no_dag_nodes && length(nodes_in_dag(rvn$nodes)) < 2
node_in_dag <- !no_dag_nodes && s_node %in% nodes_in_dag(rvn$nodes)
if (no_nodes) {
helpText(
"Use the", icon("plus"), "button above to add a node",
"to your shinyDAG workspace"
)
} else if (not_enough_nodes) {
helpText("Add another node to your shinyDAG workspace")
} else if (no_dag_nodes) {
helpText("Drag a node from the staging area into the DAG or click its label to edit")
} else if (not_enough_dag_nodes) {
helpText("Drag another node from the staging area into the DAG")
} else if (input$clickpad_click_action == "parent") {
helpText("Click on a node label to activate as causal node or to edit its label")
} else if (input$clickpad_click_action == "child") {
helpText(
"Click on a node label to draw or remove a causal arrow from",
tags$strong(node_name_from_hash(rvn$nodes, node_list_selected_node())),
"or click",
tags$strong(node_name_from_hash(rvn$nodes, node_list_selected_node())),
"again to deselect"
)
}
})
# ---- Sketch - Edge Help Text ----
req_nodes <- function() {
if (!length(rvn$nodes)) {
cat("\n No Nodes!")
edge_helptext("Please add a node to the DAG first.")
FALSE
} else TRUE
}
edge_helptext <- function(inner, tag = "div", class = "help-block text-danger alert-edge") {
edge_helptext_trigger(Sys.time())
edge_helptext_feedback(list(class = class, inner = inner, tag = tag))
}
edge_normal_help_html <- list(
inner = "Double-click on a node to set parent node. Single-click to set child node.",
class = "help-block",
tag = "p"
)
edge_helptext_trigger <- reactiveVal(Sys.time())
edge_helptext_feedback <- reactiveVal(NULL)
output$edge_list_helptext <- renderUI({
debug_input(isolate(edge_helptext_feedback()), "edge_helptext_feedback")
edge_helptext_trigger()
if (!is.null(isolate(edge_helptext_feedback()))) {
invalidateLater(4800)
}
html <- isolate(edge_helptext_feedback()) %||% edge_normal_help_html
edge_helptext_feedback(NULL)
tag(html$tag, list(class = html$class, html$inner))
})
# ---- Sketch - Clickpad ----
plotly_source_id <- paste0("clickpad_", session$token)
clickpad_new_locations <- callModule(
clickpad, "clickpad",
nodes = reactive(rvn$nodes),
edges = reactive(rve$edges),
plotly_source = plotly_source_id
)
observe({
req(clickpad_new_locations())
new <- clickpad_new_locations()
debug_input(new, "clickpad_new_locations()")
rvn$nodes <- node_update(rvn$nodes, new$hash, x = unname(new$x), y = unname(new$y))
})
# ---- Sketch - Clickpad - Click Events ----
observe({
I("clickpad click event handler")
clicked_annotation <- event_data(
"plotly_clickannotation", source = plotly_source_id, priority = "event"
)
req(clicked_annotation[["_input"]]$node_hash)
click_action = isolate(input$clickpad_click_action)
clicked_hash = clicked_annotation[["_input"]]$node_hash
nodes <- isolate(rvn$nodes)
s_node_parent <- node_parent(nodes)
s_node_child <- node_child(nodes)
if (click_action == "parent") {
# toggle clicked node as parent node
update_button <- nodes[[clicked_hash]]$x >= 0 &&
nodes %>% purrr::map_dbl("x") %>% { sum(. >= 0) > 1 }
if (is.null(s_node_parent)) {
nodes <- node_set_attribute(nodes, clicked_hash, "parent")
} else if (clicked_hash == s_node_parent) {
update_button <- FALSE
nodes <- node_unset_attribute(nodes, clicked_hash, c("parent", "child"))
} else {
nodes <- node_set_attribute(nodes, clicked_hash, "parent")
nodes <- node_unset_attribute(nodes, clicked_hash, "child")
}
if (update_button) updateRadioSwitchButtons("clickpad_click_action", "child")
} else if (click_action == "child") {
# toggle clicked node as child node
has_edge <- edge_exists(isolate(rve$edges), s_node_parent, s_node_child %||% clicked_hash)
has_reverse_edge <- edge_exists(isolate(rve$edges), s_node_child %||% clicked_hash, s_node_parent)
if (!is.null(s_node_parent) && s_node_parent == clicked_hash) {
# Can't add edges to self
rvn$nodes <- node_unset_attribute(nodes, names(nodes), c("parent", "child"))
updateRadioSwitchButtons("clickpad_click_action", "parent")
return()
} else if (has_edge) {
# Clicked on child node that already has edge, will be removing edge
nodes <- node_unset_attribute(nodes, clicked_hash, "child")
} else if (nodes[[clicked_hash]]$x < 0) {
showNotification(
"Edges can only be drawn between nodes that are in the DAG area.",
duration = 5,
type = "error"
)
return()
} else {
nodes <- node_set_attribute(nodes, clicked_hash, "child")
}
# Remove reverse edge if it exists
rv_edges <- isolate(rve$edges)
if (has_reverse_edge) {
rv_edges <- edge_toggle(rv_edges, clicked_hash, s_node_parent)
}
rve$edges <- edge_toggle(rv_edges, s_node_parent, clicked_hash)
}
rvn$nodes <- nodes
})
# ---- Sketch - Clickpad - Click Type Buttons ----
observe({
I("clickpad click action reset to select?")
reset_clickpad_action <- function() {
updateRadioSwitchButtons("clickpad_click_action", "parent")
invisible()
}
if (length(rvn$nodes) < 2) return(reset_clickpad_action())
dag_has_two_nodes <- rvn$nodes %>% purrr::map_dbl("x") %>% { sum(. >= 0) > 1 }
if (!dag_has_two_nodes) return(reset_clickpad_action())
if (!is.null(node_list_selected_node())) {
if (rvn$nodes[[node_list_selected_node()]]$x < 0) {
reset_clickpad_action()
}
}
})
# Don't allow clickpad edge adding unless node conditions are met
observeEvent(input$clickpad_click_action, {
req(input$clickpad_click_action == "child")
valid <- FALSE
if (length(rvn$nodes) < 2) {
showNotification("Please add at least 2 nodes to your DAG workspace first.", duration = 5)
} else if (rvn$nodes %>% purrr::keep(~ .$x >= 0) %>% length() < 2) {
showNotification("Please drag at least 2 nodes into the DAG area first.", duration = 5)
} else if (is.null(node_list_selected_node())) {
showNotification("A parent node must be selected first", duration = 5)
} else if (!length(nodes_in_dag(rvn$nodes))) {
showNotification(
"Please add a node to the DAG by dragging it out of the staging area.",
duration = 5
)
} else {
valid <- TRUE
}
if (!valid) updateRadioSwitchButtons("clickpad_click_action", "parent")
})
# ---- Sketch - Node Options ----
update_node_options <- function(
nodes,
inputId,
updateFn,
none_choice = TRUE,
...
) {
available_choices <- c("None" = "", node_names(nodes))
if (!none_choice) available_choices <- available_choices[-1]
s_choice <- intersect(isolate(input[[inputId]]), available_choices)
if (!length(s_choice) && none_choice) s_choice <- ""
updateFn(
session,
inputId,
choices = available_choices,
selected = s_choice,
...
)
}
observe({
update_node_options(
rvn$nodes %>% purrr::keep(~ .$x >= 0),
"adjustNode",
updateSelectizeInput
)
update_node_options(
rvn$nodes %>% purrr::keep(~ .$x >= 0),
"exposureNode",
updateSelectInput
)
update_node_options(
rvn$nodes %>% purrr::keep(~ .$x >= 0),
"outcomeNode",
updateSelectInput
)
})
observeEvent(input$exposureNode, {
nodes <- isolate(rvn$nodes)
if (input$exposureNode == "") {
rvn$nodes <- node_unset_attribute(nodes, names(nodes), "exposure")
} else if (input$exposureNode == input$outcomeNode) {
updateSelectInput(session, "outcomeNode", selected = "")
rvn$nodes <- node_unset_attribute(nodes, names(nodes), "outcome")
} else {
rvn$nodes <- node_set_attribute(nodes, input$exposureNode, "exposure")
}
})
observeEvent(input$outcomeNode, {
nodes <- isolate(rvn$nodes)
if (input$outcomeNode == "") {
rvn$nodes <- node_unset_attribute(nodes, names(nodes), "outcome")
} else if (input$outcomeNode == input$exposureNode) {
updateSelectInput(session, "exposureNode", selected = "")
rvn$nodes <- node_unset_attribute(nodes, names(nodes), "exposure")
} else {
rvn$nodes <- node_set_attribute(nodes, input$outcomeNode, "outcome")
}
})
observeEvent(input$adjustNode, {
nodes <- isolate(rvn$nodes)
if (is.null(input$adjustNode)) return()
s_adjust <- input$adjustNode
rvn$nodes <- if (length(s_adjust) == 1 && s_adjust == "") {
node_unset_attribute(nodes, names(node), "adjusted")
} else {
node_set_attribute(nodes, s_adjust, "adjusted")
}
})
output$adjustText <- renderText({
if (is.null(input$exposureNode) & is.null(input$outcomeNode)) {
paste0("Minimal sufficient adjustment sets")
} else {
paste0(
"Minimal sufficient adjustment set(s) to estimate the effect of ",
input$exposureNode,
" on ",
input$outcomeNode
)
}
})
# ---- DAG - Functions ----
make_dagitty <- function(nodes, edges, exposure = NULL, outcome = NULL, adjusted = NULL) {
dagitty_edges <- edge_frame(edges, nodes) %>%
glue::glue_data('"{from_name}" -> "{to_name}"') %>%
paste(collapse = "; ")
dagitty_code <- glue::glue("dag {{ {dagitty_edges} }}")
debug_input(dagitty_code, "dagitty_code")
gdag <- dagitty(dagitty_code)
if (isTruthy(exposure)) exposures(gdag) <- node_name_from_hash(nodes, exposure)
if (isTruthy(outcome)) outcomes(gdag) <- node_name_from_hash(nodes, outcome)
if (isTruthy(adjusted)) adjustedNodes(gdag) <- node_name_from_hash(nodes, adjusted)
gdag
}
dagitty_open_paths <- function(nodes, edges, exposure, outcome, adjusted) {
node_names <- invertNames(node_names(nodes))
gd <- make_dagitty(
edges = edges, nodes = nodes,
exposure = exposure, outcome = outcome, adjusted = adjusted
)
exp_outcome_paths <- paths(
gd,
Z = adjusted %??% unname(node_names[adjusted])
)
exp_outcome_paths$paths[as.logical(exp_outcome_paths$open)]
}
dagitty_format_paths <- function(paths) {
HTML(paste0(
"<pre><code>",
paste(trimws(paths), collapse = "\n"),
"\n</code></pre>"
))
}
# ---- Sketch - DAG - Open Exp/Outcome Paths ----
dagitty_open_exp_outcome_paths <- reactive({
req(
length(nodes_in_dag(rvn$nodes)),
length(edges_in_dag(rve$edges, rvn$nodes))
)
# need both exposure and outcome node
requires_nodes <- c("Exposure" = input$exposureNode, "Outcome" = input$outcomeNode)
missing_nodes <- names(requires_nodes[grepl("^$", requires_nodes)])
validate(
need(
length(missing_nodes) == 0,
glue::glue("Please choose {str_and(missing_nodes)} {str_plural(missing_nodes, 'node')}")
)
)
purrr::safely(dagitty_open_paths)(
nodes = rvn$nodes, edges = rve$edges, exposure = input$exposureNode,
outcome = input$outcomeNode, adjusted = input$adjustNode
)
})
output$openExpOutcomePaths <- renderUI({
validate(need(length(edges_in_dag(rve$edges, rvn$nodes)) > 0, "Please add at least one edge"))
open_paths <- dagitty_open_exp_outcome_paths()
validate(need(
is.null(open_paths$error),
paste(
"There was an error building your graph. It may not be fully or",
"correctly specified. If you have special characters in your node",
"change the node name to something short and representative. You can",
"set more detailed node labels in the \"Tweak\" panel."
)
), errorClass = " text-danger")
open_paths <- open_paths$result
if (length(open_paths)) {
tagList(
h5("Open associations between exposure and outcome"),
dagitty_format_paths(open_paths)
)
} else {
tagList(
helpText("No open associations between exposure and outcome.")
)
}
})
# ---- Tweak - Edge Aesthetics ----
# Create the edge aesthetics control UI, only updated when tab is activated
output$edge_aes_ui <- renderUI({
req(input$shinydag_page == "tweak")
req(length(isolate(rve$edges)) > 0)
rv_edge_frame <- edge_frame(isolate(rve$edges), isolate(rvn$nodes)) %>%
arrange(from_name, to_name)
tagList(
purrr:::pmap(rv_edge_frame, ui_edge_controls_row, input = input)
)
})
# Watch edge UI inputs and update rve$edges when inputs change
observe({
I("update edge aesthetics")
req(length(rve$edges) > 0, grepl("^angle__", names(input)))
rv_edges <- isolate(rve$edges)
edge_ui <- get_hashed_input_with_prefix(
input,
prefix = "angle|color|lty|lineT",
hash_sep = "__"
)
for (edge in edge_ui) {
if (!edge$hash %in% names(rv_edges)) next
this_edge <- edge[setdiff(names(edge), "hash")]
for (prop in names(this_edge)) {
if (is.na(this_edge[[prop]])) next
rv_edges[[edge$hash]][[prop]] <- this_edge[[prop]]
}
}
debug_input(bind_rows(rv_edges, .id = "hash"), "rve$edges after aes update")
rve$edges <- rv_edges
}, priority = -50)
# ---- Tweak - Node Aesthetics ----
# Create the node aesthetics control UI, only updated when tab is activated
output$node_aes_ui <- renderUI({
req(input$shinydag_page == "tweak")
req(length(isolate(rvn$nodes)) > 0)
rv_node_frame <- node_frame(isolate(rvn$nodes))
tagList(
purrr:::pmap(rv_node_frame, ui_node_controls_row, input = input)
)
})
# Watch edge UI inputs and update rve$edges when inputs change
observe({
I("update node aesthetics")
req(length(rvn$nodes) > 0, grepl("^color_fill_", names(input)))
rv_nodes <- isolate(rvn$nodes)
node_ui <- get_hashed_input_with_prefix(
input,
prefix = "name_latex|(color_(draw|fill|text))",
hash_sep = "__"
)
for (node in node_ui) {
if (!node$hash %in% names(rv_nodes)) next
this_node <- node[setdiff(names(node), "hash")]
for (prop in names(this_node)) {
if (is.na(this_node[[prop]])) next
rv_nodes[[node$hash]][[prop]] <- this_node[[prop]]
}
}
debug_input(bind_rows(rv_nodes, .id = "hash"), "rvn$nodes after aes update")
rvn$nodes <- rv_nodes
}, priority = -50)
# ---- Global - TikZ Code ----
edge_points_rv <- reactive({
req(length(rve$edges) > 0)
ep <- edge_points(rve$edges, rvn$nodes)
req(nrow(ep) > 0)
ep
})
dag_node_lines <- function(nodeFrame) {
dag_bounds <-
nodeFrame %>%
filter(!is.na(name)) %>%
summarize_at(vars(x, y), list(min = min, max = max))
nodeFrame <- nodeFrame %>%
filter(
between(x, dag_bounds$x_min, dag_bounds$x_max) &&
between(y, dag_bounds$y_min, dag_bounds$y_max)
)
nodeFrame[is.na(nodeFrame$tikz_node), "tikz_node"] <- "~"
nodeLines <- vector("character", 0)
for (i in unique(nodeFrame$y)) {
createLines <- paste0(
paste(nodeFrame[nodeFrame$y == i, ]$tikz_node, collapse = " & "),
" \\\\\n"
)
nodeLines <- c(nodeLines, createLines)
}
nodeLines <- rev(nodeLines)
paste0(
"\\matrix(m)[matrix of nodes, row sep=2.6em, column sep=2.8em,",
"text height=1.5ex, text depth=0.25ex]\n",
"{\n ", paste(nodeLines, collapse = " "), "};"
)
}
tikz_node_points <- reactive({
req(length(rvn$nodes))
update_tikz_because_global_opts()
node_df <- node_frame(rvn$nodes)
req(nrow(node_df) > 0)
node_df %>% node_frame_add_style()
})
tikz_code_from_app <- reactive({
d_tikz_node_points <- debounce(tikz_node_points, 1000)
nodePts <- d_tikz_node_points()
req(nrow(nodePts) > 0)
has_style <- any(!is.na(nodePts$tikz_style))
tikz_style_defs <- nodePts$tikz_style[!is.na(nodePts$tikz_style)]
styleZ <- paste(
"\\tikzset{",
paste0(" every node/.style={ }", if (has_style) "," else "\n}"),
if (has_style) paste(" ", tikz_style_defs, collapse = ",\n"),
if (has_style) "}",
sep = "\n"
)
startZ <- "\\begin{tikzpicture}[>=latex]"
endZ <- "\\end{tikzpicture}"
pathZ <- "\\path[->,font=\\scriptsize,>=angle 90]"
d_x <- min(nodePts$x) - 1L
d_y <- min(nodePts$y) - 1L
nodePts$x <- nodePts$x - d_x
nodePts$y <- nodePts$y - d_y
y_max <- max(nodePts$y)
nodeLines <- nodePts %>%
tidyr::complete(
x = seq(min(nodePts$x), max(nodePts$x)),
y = seq(min(nodePts$y), max(nodePts$y))
) %>%
dag_node_lines()
edgeLines <- character()
if (length(edges_in_dag(rve$edges, isolate(rvn$nodes)))) {
# edge_points_rv() is a reactive that gathers values from aesthetics UI
# but it can be noisy, so we're debouncing to delay TeX rendering until values are constant
edgePts <- debounce(edge_points_rv, 5000)()
tikz_point <- function(x, y, d_x, d_y, y_max) {
glue::glue("(m-{y_max - (y - d_y) + 1}-{x - d_x})")
}
edgePts <- edgePts %>%
mutate(
parent = tikz_point(from.x, from.y, d_x, d_y, y_max),
child = tikz_point(to.x, to.y, d_x, d_y, y_max),
edgeLine = glue::glue(
"{parent} edge [>={input$arrowShape}, bend left = {edgePts$angle}, ",
"color = {edgePts$color},{edgePts$lineT},{edgePts$lty}] node[auto] {{$~$}} {child}"
)
)
debug_input(select(edgePts, hash, matches("^(from|to)_name"), parent, child, edgeLine), "edgeLines")
edgeLines <- edgePts$edgeLine
}
edgeLines <- paste0(pathZ, paste(edgeLines, collapse = ""), ";")
paste(c(styleZ, startZ, nodeLines, edgeLines, endZ), collapse = "\n")
})
make_graph <- function(nodes, edges) {
g <- make_empty_graph()
if (nrow(node_frame(nodes))) {
g <- g + node_vertices(nodes)
}
if (length(edges)) {
# Add edges
g <- g + edge_edges(edges, nodes)
}
g
}
# ---- Tweak - Global Options ----
update_tikz_because_global_opts <- reactiveVal(FALSE)
observe({
I("update tex_opts")
`%|%` <- function(x, y) {
x <- x %||% y
if (is.na(x)) y else x
}
tex_opts$set(list(
density = 1200,
margin = list(
left = input$tex_opts_margin_left %|% 0,
top = input$tex_opts_margin_bottom %|% 0, # bug?
right = input$tex_opts_margin_right %|% 0,
bottom = input$tex_opts_margin_top %|% 0
),
cleanup = c("aux", "log")
))
update_tikz_because_global_opts(!isolate(update_tikz_because_global_opts()))
})
# ---- Tweak - dagitty DAG ----
dag_dagitty <- reactive({
req(
tweak_preview_visible(),
length(nodes_in_dag(rvn$nodes)),
length(edges_in_dag(rve$edges)),
input$exposureNode, input$outcomeNode, input$adjustNode
)
make_dagitty(rvn$nodes, rve$edges, input$exposureNode, input$outcomeNode, input$adjustNode)
})
dag_tidy <- reactive({
req(
tweak_preview_visible(),
length(nodes_in_dag(rvn$nodes)),
length(edges_in_dag(rve$edges)),
input$exposureNode, input$outcomeNode, input$adjustNode
)
make_dagitty(rvn$nodes, rve$edges, input$exposureNode, input$outcomeNode, input$adjustNode) %>%
tidy_dagitty()
})
# ---- Tweak - Preview ----
tweak_preview_visible <- callModule(
module = dagPreview,
id = "tweak_preview",
session_dir = SESSION_TEMPDIR,
tikz_code = reactive({
req(input$shinydag_page == "tweak")
tikz_code_from_app()
}),
dag_dagitty,
dag_tidy,
has_edges = reactive(nrow(edge_frame(rve$edges, rvn$nodes)))
)
# ---- LaTeX - Editor ----
output$texEdit <- renderUI({
tikz_lines <- tikz_code_from_app()
if (is.null(tikz_lines)) {
tikz_lines <- "\\\\begin{tikzpicture}[>=latex]\n\\\\end{tikzpicture}"
} else {
# double escape backslashes
tikz_lines <- gsub("\\", "\\\\", tikz_lines, fixed = TRUE)
}
aceEditor(
"manual_tikz",
mode = "latex",
value = paste(tikz_lines, collapse = "\n"),
theme = "chrome",
wordWrap = TRUE,
highlightActiveLine = TRUE
)
})
latex_preview_visible <- callModule(
module = dagPreview,
id = "latex_preview",
session_dir = SESSION_TEMPDIR,
reactive({
req(input$shinydag_page == "latex")
input$manual_tikz
})
)
# ---- About - Examples ----
example_value <- callModule(examples, "example")
observe({
req(example_value())
ex_val <- example_value()
rvn$nodes <- ex_val$nodes
rve$edges <- ex_val$edges
Sys.sleep(0.25)
shinydashboard::updateTabItems(session, "shinydag_page", "sketch")
})
}

View file

@ -0,0 +1,13 @@
Version: 1.0
RestoreWorkspace: No
SaveWorkspace: No
AlwaysSaveHistory: Default
EnableCodeIndexing: Yes
UseSpacesForTab: Yes
NumSpacesForTab: 2
Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX

357
apps/shinyDAG-1.0.0/ui.R Normal file
View file

@ -0,0 +1,357 @@
# Components --------------------------------------------------------------
components <- list(toolbar = list())
# Components - Clickpad ----
components$toolbar$clickpad_action <- tags$div(
radioSwitchButtons(
"clickpad_click_action",
HTML(paste(icon("mouse-pointer"), "Click a node to...")),
choices = c("Select" = "parent", "Draw/Remove Edge" = "child"),
selected = "parent",
selected_background = "#D3751C"
)
)
# Components - Node List ----
components$toolbar$node_list_actions <- tags$div(
class = "btn-toolbar",
role = "toolbar",
tags$form(
class = "form-inline",
tags$div(
class = "form-group",
tags$div(
class = "btn-group",
role = "group",
actionButton(
input = "node_list_node_add",
label = "Add New Node",
icon = icon("plus"),
alt = "Add New Node to Workspace",
`data-toggle` = "tooltip",
`data-placement` = "bottom",
title = "Add New Node to Workspace"
),
shinyjs::hidden(
actionButton(
"node_list_node_delete", "Delete Node", icon("trash"),
alt = "Delete Node",
`data-toggle` = "tooltip",
`data-placement` = "bottom",
title = "Delete Node")
)
)
)
)
)
components$toolbar$node_list_name <- tags$div(
style = "padding-top: 15px; min-height: 90px;",
shinyjs::hidden(
tags$div(
id = "node_list_node_name_container",
class = "col-xs-12",
textInput("node_list_node_name", "Node Name", width = "100%")
)
)
)
# Components - About ----
components$about <- list()
components$about$gerkelab <- tagList(
h3("Development Team"),
tags$ul(
tags$li("Jordan Creed"),
tags$li(tags$a(href = "https://www.garrickadebuie.com", "Garrick Aden-Buie")),
tags$li(tags$a(href = "https://travisgerke.com", "Travis Gerke"))
),
p(
"For more information about our lab and other projects please check",
"out our website at",
tags$a(href = "http://gerkelab.com", "gerkelab.com")
),
p(
"All code and detailed instructions for usage is available on GitHub at",
tags$a(
href = "https://github.com/GerkeLab/shinyDAG",
"GerkeLab/shinyDag"
)
),
p(
"If you have any questions or comments, we would love to hear them.",
"You can email us at",
tags$a(href = "mailto:travis.gerke@moffitt.org", "travis.gerke@moffitt.org"),
"or",
HTML(paste0(
tags$a(href = "mailto:jordan.h.creed@moffitt.org", "jordan.h.creed@moffitt.org"),
"."
)),
"Or feel free to",
tags$a(
href = "https://github.com/GerkeLab/shinyDAG/issues",
"open an issue"
),
"in our GitHub repository."
)
)
# components$about$usage <- tagList(
# tags$h3("Using shinyDAG"),
# tags$p(
# "For more details on using shinyDAG please check out our",
# tags$a(
# href = "https://github.com/GerkeLab/shinyDAG/blob/master/README.md",
# "README."
# ))
# )
# Components - Build ----
components$build <- box(
title = "Build",
id = "build-box",
width = 12,
fluidRow(
id = "shinydag-toolbar",
tags$div(
class = "col-xs-12 col-md-5 shinydag-toolbar-actions",
tags$div(
class = "col-xs-12 col-sm-6 col-md-12",
id = "shinydag-toolbar-node-list-action",
components$toolbar$node_list_action
),
tags$div(
class = "col-xs-12 col-sm-6 col-md-12",
style = "padding: 10px",
id = "shinydag-toolbar-clickpad-action",
components$toolbar$clickpad_action
)
),
tags$div(
class = "col-xs-12 col-md-7",
components$toolbar$node_list_name
)
),
fluidRow(
column(
width = 12,
tags$div(
class = "pull-left",
uiOutput("node_list_helptext")
),
shinyThings::undoHistoryUI(
id = "undo_rv",
class = "pull-right",
back_text = "Undo",
fwd_text = "Redo"
)
)
),
fluidRow(
column(
width = 12,
clickpad_UI("clickpad", height = "600px", width = "100%")
)
),
if (getOption("shinydag.debug", FALSE)) fluidRow(
column(width = 12, shinyThings::undoHistoryUI_debug("undo_rv"))
),
fluidRow(
tags$div(
class = class_3_col,
selectInput("exposureNode", "Exposure", choices = c("None" = ""), width = "100%")
),
tags$div(
class = class_3_col,
selectInput("outcomeNode", "Outcome", choices = c("None" = ""), width = "100%")
),
tags$div(
class = class_3_col,
selectizeInput("adjustNode", "Adjust for...", choices = c("None" = ""), width = "100%", multiple = TRUE)
)
),
fluidRow(
tags$div(
class = "col-sm-12",
uiOutput("openExpOutcomePaths")
)
)
)
# Components - LaTeX ----
components$latex <- tagList(
tags$p(
"Use this tab to manually edit the TikZ generated by shinyDAG."
),
helpText(
"Note that changes made to the TikZ code below will not affect",
"the DAG settings in the app. Changes made to the DAG elsewhere",
"in shinyDAG will overwrite any changes made to the manually",
"edited TikZ code below."
),
uiOutput("texEdit")
)
# Components - Tweak ----
components$tweak <- tabBox(
title = "Edit DAG",
id = "tab_control",
# ---- Tab: Edit Aesthetics
tabPanel(
"Edges",
value = "edit_edge_aesthetics",
selectInput(
"arrowShape",
"Select arrow head",
choices = c(
"stealth",
"stealth'",
"diamond",
"triangle 90",
"hooks",
"triangle 45",
"triangle 60",
"hooks reversed",
"*"
),
selected = "stealth"
),
uiOutput("edge_aes_ui")
),
tabPanel(
"Nodes",
value = "edit_node_aesthetics",
uiOutput("node_aes_ui")
),
tabPanel(
"Page",
value = "edit_page_aesthetics",
tags$h3("Margins"),
fluidRow(
col_4(
numericInput("tex_opts_margin_top", "Top", value = 0L, min = 0L, max = 500L, step = 1L)
),
col_4(
numericInput("tex_opts_margin_right", "Right", value = 0L, min = 0L, max = 500L, step = 1L)
),
col_4(
numericInput("tex_opts_margin_bottom", "Bottom", value = 0L, min = 0L, max = 500L, step = 1L)
),
col_4(
numericInput("tex_opts_margin_left", "Left", value = 0L, min = 0L, max = 500L, step = 1L)
)
)
)
)
# UI - shinyDAG -----------------------------------------------------------
function(request) {
dashboardPage(
title = "shinyDAG",
skin = "black",
dashboardHeader(
title = "shinyDAG",
tags$li(
class = "dropdown",
actionLink(
inputId = "._bookmark_",
label = "Bookmark",
icon = icon("link", lib = "glyphicon"),
title = "Bookmark shinyDAG's state and get a URL for sharing.",
`data-toggle` = "tooltip",
`data-placement` = "bottom"
)
),
tags$li(
class = "dropdown",
tags$a(
href = "https://github.com/gerkelab/shinyDAG/",
title = "shinyDAG on GitHub",
target = "_blank",
icon("github")
)
),
tags$li(
class = "dropdown",
tags$a(
href = "https://gerkelab.com/project/shinyDAG/",
title = "GerkeLab Project Page",
target = "_blank",
icon("flask")
)
)
),
dashboardSidebar(
sidebarMenu(
id = "shinydag_page",
menuItem("Sketch", tabName = "sketch", icon = icon("share-alt")),
menuItem("Tweak", tabName = "tweak", icon = icon("sliders")),
menuItem("LaTeX", tabName = "latex", icon = icon("file-text-o")),
menuItem("About", tabName = "about", icon = icon("info"))
)
),
dashboardBody(
shinyjs::useShinyjs(),
tags$script(src = "shinydag.js", async = TRUE),
includeCSS("www/AdminLTE.gerkelab.min.css"),
includeCSS("www/_all-skins.gerkelab.min.css"),
includeCSS("www/shinydag.css"),
chooseSliderSkin("Flat", "#418c7a"),
tags$a(
href = "https://gerkelab.com",
target = "_blank",
tags$div(class = "gerkelab-logo")
),
tabItems(
tabItem(
tabName = "sketch",
components$build
),
tabItem(
tabName = "tweak",
two_column_flips_on_mobile(
components$tweak,
box(
title = "Preview DAG",
dagPreviewUI("tweak_preview", include_graph_downloads = TRUE)
)
)
),
tabItem(
tabName = "latex",
two_column_flips_on_mobile(
box(
title = "Edit LaTeX",
components$latex
),
box(
title = "Preview LaTeX",
dagPreviewUI("latex_preview", include_graph_downloads = FALSE)
)
)
),
tabItem(
tabName = "about",
box(
title = "Examples",
width = "12 col-md-6",
examples_UI("example")
),
box(
title = "About shinyDAG",
width = "12 col-md-6",
components$about$gerkelab
)#,
# box(
# title = "About shinyDAG",
# width = "12 col-md-6",
# components$about$usage
# )
)
)
)
)
}

File diff suppressed because one or more lines are too long

Binary file not shown.

After

Width:  |  Height:  |  Size: 14 KiB

File diff suppressed because one or more lines are too long

View file

@ -0,0 +1,31 @@
## Creating Examples
To create a new example, run ShinyDAG locally using the shinydag dev docker file.
Set up your example and then save it as a bookmark.
Note the URL created by shiny for the bookmark, it should end with
```
?_state_id_=9d49cb0ba72b00f2
```
Navigate to the `shiny_bookmarks` folder and find the folder with the bookmark token, e.g. `9d49cb0ba72b00f2`.
Copy `values.rds` to `www/examples` and give the file a descriptive name.
These names are used for the shiny inputs, so keep the characters sane (and no spaces).
Also, save the DAG image into `www/examples` with the same name (not required but a good idea).
Finally, add the description text to `www/examples/examples.yml`.
Here's an example template that you can copy.
Note that if you can use HTML in the `description`, but it needs to be valid or it will cause problems on the page.
```yaml
- name: Classic Confounding
description: >
This is a description of classic confounding. Descriptions may include
<strong>HTML</strong>.
file: classic-confounding.rds
image: classic-confounding.png
```

Binary file not shown.

After

Width:  |  Height:  |  Size: 19 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 40 KiB

View file

@ -0,0 +1,23 @@
- name: Classic Confounding
description: >
This depicts <em>classic confounding</em>, where a confounder C is a common cause of exposure (E) and outcome (Y).
file: classic-confounding.rds
image: classic-confounding.png
- name: Differential Loss to Follow-Up
description: >
This depicts <em>differential loss to follow up</em>, where patients may be censored (C) depending on their value of L.
file: differential-loss-to-follow-up.rds
image: differential-loss-to-follow-up.png
- name: Mediator with Confounding
description: >
This shows a <em>mediator with confounding</em>, where the variable M mediates the effect of E on Y, which is confounded by the variable C.
file: mediator-with-confounding.rds
image: mediator-with-confounding.png
- name: Selection Bias
description: >
This depicts classic <em>selection bias</em>, where C denotes criteria under which the data are observed which, in turn, is a downstream consequence of exposure (E) and outcome (D).
file: selection-bias.rds
image: selection-bias.png

Binary file not shown.

After

Width:  |  Height:  |  Size: 28 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 15 KiB

Binary file not shown.

View file

@ -0,0 +1,264 @@
@import url('https://fonts.googleapis.com/css?family=Lato:300,400,400i,700,700i');
@media (min-width: 768px) and (max-width: 991px) {
#shinydag-toolbar-node-list-action {
padding-top: 32px;
}
}
/* ---- GerkeLab Admin LTE Theme Tweaks ---- */
body, h1, h2, h3, h4, h5, h6, .h1, .h2, .h3, .h4, .h5, .h6, .main-header .logo {
font-family: Lato, sans-serif;
}
.main-header > .logo {
color: #989898 !important;
text-decoration: none;
font-weight: bold;
}
.main-header {
position: fixed;
width: 100%;
box-shadow: 0 3px 3px rgba(0,0,0,0.1) !important;
-webkit-box-shadow: 0 3px 3px rgba(0,0,0,0.1) !important;
}
.wrapper, .content-wrapper {
min-height: 100vh !important;
height: 100% !important;
background-color: #f0f0f0 !important;
}
@media (max-width:767px) {
.content-wrapper {
padding-top: 100px;
}
}
@media (min-width:768px) {
.content-wrapper {
padding-top: 50px;
}
}
.skin-black .main-header .navbar .navbar-custom-menu .navbar-nav > li > a,
.skin-black .main-header .navbar .navbar-right > li > a {
border-left: none;
}
.gerkelab-logo {
background: url("GerkeLab.png");
background-size: contain;
width: 100px;
height: 100px;
position: absolute;
bottom: 25px;
left: 65px;
filter: drop-shadow(0 3px 4px rgba(0,0,0,0.2));
transition: z-index 0s, left 0.25s ease-in-out, filter 0.25s ease-in-out, opacity 1s ease-in-out;
z-index: 1000;
opacity: 1;
}
.sidebar-collapse .gerkelab-logo {
transition: z-index 0s 0.5s, left 0.25s ease-in-out, filter 0.25s ease-in-out;
z-index: 0;
left: 2%;
bottom: 25px;
}
.sidebar-collapse .gerkelab-logo:hover {
filter: drop-shadow(0 0 1px rgba(0,0,0,0.2));
}
@media (max-width: 767px) {
.gerkelab-logo {
z-index: 0;
opacity: 0;
}
}
.disable-buttons {
pointer-events: none;
}
.disabled {
pointer-events: none;
}
#shiny-tab-sketch .box {
margin-bottom: 100px;
}
.dag-preview-tikz {
min-height: 400px;
}
.example-image {
text-align: center;
}
.example-image img {
width: 80%;
max-width: 500px;
}
/* ---- ShinyDAG specific tweaks ---- */
#edge_aes_ui label {
color: #777;
font-weight: normal;
}
#showPreviewContainer {
padding-top: 32px;
}
.dagpreview-download-ui {
padding-top: 25px;
}
#node_delete {
margin-top: 20px;
color: #FFF
}
#edge_btn {
margin-top: 25px;
color: #FFF
}
#ui_edge_swap_btn {
margin-top: 25px;
}
@media (min-width: 768px) {
#node_delete {
margin-left: -25px;
}
}
.edge-selector-hint {
font-size: 28px;
line-height: 14px;
padding-left: 4px;
vertical-align: top;
}
.help-block {
padding-top: 0;
font-style: italic;
}
.help-block.text-warning {
color: #db8b0b;
background-color: #db8b0b20;
}
.help-block.text-danger {
color: #d33724;
background-color: #d3372420;
}
#edge_list_helptext .help-block, #node_list_helptext .help-block {
padding: 0.5em;
border-radius: 3px;
}
.btn-text {
padding-left: 5px;
}
@media (min-width: 992px) and (max-width: 1825px) {
.btn-text {
display: none;
}
}
.gerkelab-spinner {
margin: auto;
width: 100px;
height: 100px;
background: url("GerkeLab.png");
background-size: cover;
-webkit-animation-name: spin;
-webkit-animation-duration: 4000ms;
-webkit-animation-iteration-count: infinite;
-webkit-animation-timing-function: linear;
-moz-animation-name: spin;
-moz-animation-duration: 4000ms;
-moz-animation-iteration-count: infinite;
-moz-animation-timing-function: linear;
-ms-animation-name: spin;
-ms-animation-duration: 4000ms;
-ms-animation-iteration-count: infinite;
-ms-animation-timing-function: linear;
animation-name: spin;
animation-duration: 4000ms;
animation-iteration-count: infinite;
animation-timing-function: linear;
}
@-ms-keyframes spin {
from { -ms-transform: rotate(0deg); }
to { -ms-transform: rotate(-360deg); }
}
@-moz-keyframes spin {
from { -moz-transform: rotate(0deg); }
to { -moz-transform: rotate(-360deg); }
}
@-webkit-keyframes spin {
from { -webkit-transform: rotate(0deg); }
to { -webkit-transform: rotate(-360deg); }
}
@keyframes spin {
from {
transform:rotate(0deg);
}
to {
transform:rotate(-360deg);
}
}
.alert-edge {
animation: fadeout 5s;
-moz-animation: fadeout 5s;
-webkit-animation: fadeout 5s;
-o-animation: fadeout 5s;
}
@keyframes fadeout {
0% {
opacity: 1;
}
75% {
opacity: 1;
}
100% {
opacity: 0;
}
}
@-moz-keyframes fadeout {
0% {
opacity: 1;
}
75% {
opacity: 1;
}
100% {
opacity: 0;
}
}
@-webkit-keyframes fadeout {
0% {
opacity: 1;
}
75% {
opacity: 1;
}
100% {
opacity: 0;
}
}

View file

@ -0,0 +1,78 @@
const set_input_focus = (id) => {
const el = document.getElementById(id);
if (el) {
el.focus();
}
};
const wrap_btn_text_in_span = (id, text) => {
var $el = $("#" + id);
$el.html([$el.children()[0], "<span class='btn-text'>" + text + "</span>"]);
};
$( document ).ready(function() {
setTimeout(function() {wrap_btn_text_in_span("downloadButton", "Download")}, 1000);
setTimeout(function() {wrap_btn_text_in_span("\\._bookmark_", "Bookmark")}, 1000);
});
// Block name change updates while Shiny is re-rendering to avoid wonkiness
var text_input_timeout;
$(document).on("shiny:busy", (e) => {
text_input_timeout = setTimeout(() => {
$("#node_list_node_name").prop("disabled", true);
}, 500);
});
$(document).on("shiny:idle", (e) => {
clearTimeout(text_input_timeout);
$("#node_list_node_name").prop("disabled", false);
});
// Block node change buttons when updating names to avoid infinite looping wonkiness
// disables buttons when user starts typing in text box
$("#node_list_node_name").keydown(() => {
$("#shinydag-toolbar-node-list-action button").prop("disabled", true);
});
// re-enable buttons when Shiny updates or the text bar loses focus (in case no change)
$(document).on("shiny:value", () => {
$("#shinydag-toolbar-node-list-action button").prop("disabled", false);
});
$("#node_list_node_name").blur(() => {
$("#shinydag-toolbar-node-list-action button").prop("disabled", false);
});
// Block undo/redo buttons during Shiny updates as well
var undo_disable_timeout = null;
$("#undo_rv-history_back, #undo_rv-history_forward").on("click", () => {
undo_disable_timeout = setTimeout(() => {
$("#undo_rv-history_back").parent().addClass("disable-buttons");
}, 10);
})
// Bock undo/redo with a delay for general Shiny updates
$(document).on("shiny:busy", () => {
if (!undo_disable_timeout) {
undo_disable_timeout = setTimeout(() => {
$("#undo_rv-history_back").parent().addClass("disable-buttons");
}, 250);
}
});
// re-enable undo/redo buttons when Shiny is idle
$(document).on("shiny:idle", () => {
clearTimeout(undo_disable_timeout);
undo_disable_timeout = null;
$("#undo_rv-history_back").parent().removeClass("disable-buttons");
});
// Animate logo when app is busy
var app_busy_timeout;
$(document).on("shiny:busy", e => {
app_busy_timeout = setTimeout(() => {
$(".gerkelab-logo").addClass("gerkelab-spinner");
}, 500);
});
$(document).on("shiny:idle", e => {
clearTimeout(app_busy_timeout);
$(".gerkelab-logo").removeClass("gerkelab-spinner");
});

16
apps/shinyDAG.R Normal file
View file

@ -0,0 +1,16 @@
## -----------------------------------------------------------------------------
## shinyDAG app
## -----------------------------------------------------------------------------
##
## Copy from https://github.com/gadenbuie/ShinyDAG for local deployment
##
old_wd<-getwd()
setwd(paste0(old_wd,"/apps/shinyDAG-1.0.0"))
shiny::runApp()
source(paste0(old_wd,"/apps/app_deploy.R"))
setwd(old_wd)