├── .gitignore ├── .travis.yml ├── Dockerfile ├── Figures ├── AddNodeEdge.gif ├── editEdge.gif ├── example1.png ├── example1_hernan.png ├── paths.png └── paths2.png ├── LICENSE ├── R ├── aes_ui.R ├── columns.R ├── edge.R ├── inputs.R ├── module │ ├── clickpad.R │ ├── dagPreview.R │ └── examples.R ├── node.R ├── tests │ └── test-escape_latex.R └── xcolorPicker.R ├── README.md ├── VERSION ├── data └── xcolors.csv ├── dev ├── Dockerfile └── README.md ├── global.R ├── server.R ├── shinydag.Rproj ├── ui.R └── www ├── AdminLTE.gerkelab.min.css ├── GerkeLab.png ├── _all-skins.gerkelab.min.css ├── examples ├── README.md ├── classic-confounding.png ├── classic-confounding.rds ├── differential-loss-to-follow-up.png ├── differential-loss-to-follow-up.rds ├── examples.yml ├── mediator-with-confounding.png ├── mediator-with-confounding.rds ├── selection-bias.png └── selection-bias.rds ├── shinydag.css └── shinydag.js /.gitignore: -------------------------------------------------------------------------------- 1 | # ---- Project files ---- 2 | shiny_bookmarks/ 3 | www/errors/* 4 | 5 | # ---- Default .gitignore From grkmisc ---- 6 | .Rproj.user 7 | .Rhistory 8 | .RData 9 | .DS_Store 10 | 11 | # Directories that start with _ 12 | _*/ 13 | 14 | ## https://github.com/github/gitignore/blob/master/R.gitignore 15 | # History files 16 | .Rhistory 17 | .Rapp.history 18 | 19 | # Session Data files 20 | .RData 21 | 22 | # Example code in package build process 23 | *-Ex.R 24 | 25 | # Output files from R CMD build 26 | /*.tar.gz 27 | 28 | # Output files from R CMD check 29 | /*.Rcheck/ 30 | 31 | # RStudio files 32 | .Rproj.user/ 33 | 34 | # produced vignettes 35 | vignettes/*.html 36 | vignettes/*.pdf 37 | 38 | # OAuth2 token, see https://github.com/hadley/httr/releases/tag/v0.3 39 | .httr-oauth 40 | 41 | # knitr and R markdown default cache directories 42 | /*_cache/ 43 | /cache/ 44 | 45 | # Temporary files created by R markdown 46 | *.utf8.md 47 | *.knit.md 48 | 49 | # Shiny token, see https://shiny.rstudio.com/articles/shinyapps.html 50 | rsconnect/ 51 | 52 | ## https://github.com/github/gitignore/blob/master/Global/macOS.gitignore 53 | # General 54 | .DS_Store 55 | .AppleDouble 56 | .LSOverride 57 | 58 | # Icon must end with two \r 59 | Icon 60 | 61 | 62 | # Thumbnails 63 | ._* 64 | 65 | # Files that might appear in the root of a volume 66 | .DocumentRevisions-V100 67 | .fseventsd 68 | .Spotlight-V100 69 | .TemporaryItems 70 | .Trashes 71 | .VolumeIcon.icns 72 | .com.apple.timemachine.donotpresent 73 | 74 | # Directories potentially created on remote AFP share 75 | .AppleDB 76 | .AppleDesktop 77 | Network Trash Folder 78 | Temporary Items 79 | .apdisk 80 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | services: 3 | - docker 4 | 5 | env: 6 | global: 7 | - DOCKER_USER="grrrck" 8 | - DOCKER_ORG="gerkelab" 9 | - 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=" 10 | - COMMIT=${TRAVIS_COMMIT::8} 11 | - REPO="shinydag" 12 | 13 | script: 14 | - docker build -f Dockerfile -t $DOCKER_ORG/$REPO:$COMMIT . 15 | 16 | after_success: 17 | - docker login -u $DOCKER_USER -p $DOCKER_PASS 18 | - if [[ $TRAVIS_PULL_REQUEST == "false" ]] && [[ $TRAVIS_BRANCH == "master" ]]; then 19 | docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:latest; 20 | docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:$TRAVIS_BUILD_NUMBER; 21 | docker push $DOCKER_ORG/$REPO; 22 | fi 23 | - if [[ $TRAVIS_PULL_REQUEST == "false" ]] && [[ $TRAVIS_BRANCH == "dev" ]]; then 24 | docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:dev; 25 | docker tag $DOCKER_ORG/$REPO:$COMMIT $DOCKER_ORG/$REPO:$TRAVIS_BUILD_NUMBER; 26 | docker push $DOCKER_ORG/$REPO; 27 | fi 28 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rocker/shiny-verse:3.5.3 2 | 3 | LABEL maintainer="Travis Gerke (Travis.Gerke@moffitt.org)" 4 | 5 | # Install system dependencies for required packages 6 | RUN apt-get update -qq && apt-get -y --no-install-recommends install \ 7 | libssl-dev \ 8 | libxml2-dev \ 9 | libmagick++-dev \ 10 | libv8-3.14-dev \ 11 | libglu1-mesa-dev \ 12 | freeglut3-dev \ 13 | mesa-common-dev \ 14 | libudunits2-dev \ 15 | libpoppler-cpp-dev \ 16 | libwebp-dev \ 17 | && apt-get clean \ 18 | && rm -rf /var/lib/apt/lists/ \ 19 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 20 | 21 | RUN install2.r --error \ 22 | shinyAce \ 23 | shinydashboard \ 24 | shinyWidgets \ 25 | DiagrammeR \ 26 | ggdag \ 27 | igraph \ 28 | pdftools \ 29 | shinyBS \ 30 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 31 | 32 | RUN Rscript -e "devtools::install_github('metrumresearchgroup/texPreview', ref = 'e954322')" \ 33 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 34 | 35 | # Install TinyTeX 36 | RUN install2.r --error tinytex \ 37 | && wget -qO- \ 38 | "https://github.com/yihui/tinytex/raw/master/tools/install-unx.sh" | \ 39 | sh -s - --admin --no-path \ 40 | && mv ~/.TinyTeX /opt/TinyTeX \ 41 | && /opt/TinyTeX/bin/*/tlmgr path add \ 42 | && tlmgr install metafont mfware inconsolata tex ae parskip listings \ 43 | && tlmgr install standalone varwidth xcolor colortbl multirow psnfss setspace pgf \ 44 | && tlmgr path add \ 45 | && Rscript -e "tinytex::r_texmf()" \ 46 | && chown -R root:staff /opt/TinyTeX \ 47 | && chmod -R a+w /opt/TinyTeX \ 48 | && chmod -R a+wx /opt/TinyTeX/bin \ 49 | && echo "PATH=${PATH}" >> /usr/local/lib/R/etc/Renviron \ 50 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 51 | 52 | RUN install2.r --error shinyjs \ 53 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 54 | 55 | RUN install2.r --error plotly shinycssloaders \ 56 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 57 | 58 | RUN installGithub.r gadenbuie/shinyThings@4e8becb2972aa2f7f1960da6e5fe6ad39aeceda0 \ 59 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 60 | 61 | ARG SHINY_APP_IDLE_TIMEOUT=600 62 | RUN sed -i "s/directory_index on;/app_idle_timeout ${SHINY_APP_IDLE_TIMEOUT};/g" /etc/shiny-server/shiny-server.conf 63 | COPY . /srv/shiny-server/shinyDAG 64 | RUN chown -R shiny:shiny /srv/shiny-server/ 65 | -------------------------------------------------------------------------------- /Figures/AddNodeEdge.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/AddNodeEdge.gif -------------------------------------------------------------------------------- /Figures/editEdge.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/editEdge.gif -------------------------------------------------------------------------------- /Figures/example1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/example1.png -------------------------------------------------------------------------------- /Figures/example1_hernan.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/example1_hernan.png -------------------------------------------------------------------------------- /Figures/paths.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/paths.png -------------------------------------------------------------------------------- /Figures/paths2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/Figures/paths2.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Jordan Creed and Travis Gerke 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /R/aes_ui.R: -------------------------------------------------------------------------------- 1 | 2 | # * ui_edge_controls() builds an individual UI control element. These elements 3 | # are re-rendered whenever the tab is opened, so this function finds the 4 | # current value of the input and uses that instead of the value declared 5 | # in the definition in ui_edge_controls_row(). This function also isolates 6 | # the edge control UI from other changes in nodes, etc, because they happen 7 | # on different screens. 8 | ui_controls <- function(hash, inputFn, prefix_input, label, ..., input = NULL) { 9 | stopifnot(!is.null(input)) 10 | current_value_arg_name <- intersect(names(list(...)), c("selected", "value")) 11 | if (!length(current_value_arg_name)) { 12 | stop("Must specifiy `selected` or `value` when specifying edge UI controls") 13 | } 14 | input_name <- paste(prefix_input, hash, sep = "__") 15 | input_label <- label 16 | 17 | if (input_name %in% names(isolate(input))) { 18 | # Make sure current value doesn't change 19 | dots <- list(...) 20 | dots[current_value_arg_name] <- paste(isolate(input[[input_name]])) 21 | dots$inputId <- input_name 22 | dots$label <- HTML(input_label) 23 | do.call(inputFn, dots) 24 | } else { 25 | # Create new input 26 | inputFn(input_name, HTML(input_label), ...) 27 | } 28 | } 29 | 30 | get_hashed_input_with_prefix <- function(input, prefix, hash_sep = "__") { 31 | prefix <- glue::glue("^({prefix}){hash_sep}") 32 | 33 | tibble( 34 | inputId = grep(prefix, names(input), value = TRUE) 35 | ) %>% 36 | filter(!grepl("-selectized$", inputId)) %>% 37 | # get current value of input 38 | mutate(value = lapply(inputId, function(x) input[[x]])) %>% 39 | tidyr::separate(inputId, into = c("var", "hash"), sep = hash_sep) %>% 40 | tidyr::spread(var, value) %>% 41 | mutate_if(is.list, ~ purrr::map(.x, ~ if (is.null(.x)) NA else .x)) %>% 42 | tidyr::unnest() %>% 43 | split(.$hash) 44 | } 45 | 46 | # The input for angles (here for easy refactoring or future changes) 47 | selectDegree <- function(inputId, label = "Degree", min = -180, max = 180, by = 15, value = 0, ...) { 48 | sliderInput(inputId, label = label, min = min, max = max, value = value, step = by) 49 | } 50 | 51 | 52 | # Edge Aesthetic UI ------------------------------------------------------- 53 | 54 | # These helper functions build up the Edge UI elements. 55 | # 56 | # * ui_edge_controls_row() creates the entire row of UI elements for a given 57 | # edge. This function is where the UI inputs are initially defined. 58 | 59 | ui_edge_controls_row <- function(hash, from_name, to_name, ..., input = NULL) { 60 | stopifnot(!is.null(input)) 61 | 62 | extra <- list(...) 63 | 64 | col_4 <- function(x) { 65 | tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x) 66 | } 67 | title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x)) 68 | edge_label <- paste0(from_name, " → ", to_name) 69 | 70 | tagList( 71 | fluidRow( 72 | title_row(HTML(edge_label)) 73 | ), 74 | fluidRow( 75 | # Edge Curve Angle 76 | col_4(ui_controls( 77 | hash, 78 | inputFn = selectDegree, 79 | prefix_input = "angle", 80 | label = "Angle", 81 | value = extra[["angle"]] %||% 0, 82 | width = "95%", 83 | input = input 84 | )), 85 | # Edge Color 86 | col_4(ui_controls( 87 | hash, 88 | inputFn = xcolorPicker, 89 | prefix_input = "color", 90 | label = "Edge", 91 | selected = extra[["color"]] %||% "Black", 92 | width = "95%", 93 | input = input 94 | )), 95 | # Curve Angle 96 | col_4(ui_controls( 97 | hash, 98 | inputFn = selectInput, 99 | prefix_input = "lty", 100 | label = "Line Type", 101 | choices = c("solid", "dashed"), 102 | selected = extra[["lty"]] %||% "solid", 103 | width = "95%", 104 | input = input 105 | )), 106 | # Curve Angle 107 | col_4(ui_controls( 108 | hash, 109 | inputFn = selectInput, 110 | prefix_input = "lineT", 111 | label = "Line Thickness", 112 | choices = c("ultra thin", "very thin", "thin", "semithick", "thick", "very thick", "ultra thick"), 113 | selected = extra[["lineT"]] %||% "thin", 114 | width = "95%", 115 | input = input 116 | )) 117 | ) 118 | ) 119 | } 120 | 121 | 122 | # Node Aesthetic UI ------------------------------------------------------- 123 | 124 | ui_node_controls_row <- function(hash, name, adjusted, name_latex, ..., input = NULL) { 125 | stopifnot(!is.null(input)) 126 | 127 | extra <- list(...) 128 | 129 | col_4 <- function(x) { 130 | tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x) 131 | } 132 | title_row <- function(x) tags$div(class = "col-xs-12", tags$h3(x)) 133 | 134 | tagList( 135 | fluidRow( 136 | title_row(HTML(name)) 137 | ), 138 | fluidRow( 139 | # LaTeX version of node label 140 | col_4(ui_controls( 141 | hash, 142 | inputFn = textInput, 143 | prefix_input = "name_latex", 144 | label = "LaTeX Label", 145 | value = name_latex, 146 | width = "95%", 147 | input = input 148 | )), 149 | # Text Color 150 | col_4(ui_controls( 151 | hash, 152 | inputFn = xcolorPicker, 153 | prefix_input = "color_text", 154 | label = "Text", 155 | selected = extra[["color_text"]] %||% "Black", 156 | width = "95%", 157 | input = input 158 | )), 159 | # Fill Color 160 | col_4(ui_controls( 161 | hash, 162 | inputFn = xcolorPicker, 163 | prefix_input = "color_fill", 164 | label = "Fill", 165 | selected = extra[["color_fill"]] %||% "White", 166 | width = "95%", 167 | input = input 168 | )), 169 | # Box Color (if shown) 170 | if (adjusted) { 171 | col_4(ui_controls( 172 | hash, 173 | inputFn = xcolorPicker, 174 | prefix_input = "color_draw", 175 | label = "Border", 176 | selected = extra[["color_draw"]] %||% "Black", 177 | width = "95%", 178 | input = input 179 | )) 180 | } 181 | ) 182 | ) 183 | } 184 | -------------------------------------------------------------------------------- /R/columns.R: -------------------------------------------------------------------------------- 1 | class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12" 2 | 3 | 4 | # Component Builders ------------------------------------------------------ 5 | 6 | two_column_flips_on_mobile <- function(left, right, override_width_classes = TRUE) { 7 | 8 | left_col_class <- "col-sm-12 col-md-pull-6 col-md-6 col-lg-5 col-lg-pull-7" 9 | right_col_class <- "col-sm-12 col-md-push-6 col-md-6 col-lg-7 col-lg-push-5" 10 | 11 | if (!override_width_classes) { 12 | right <- tags$div(class = right_col_class, right) 13 | left <- tags$div(class = left_col_class, left) 14 | } else { 15 | strip_col_class <- function(x) gsub("col-(xs|sm|md|lg)-\\d{1,2}\\s*", "", x) 16 | left$attrib$class <- strip_col_class(left$attrib$class) 17 | right$attrib$class <- strip_col_class(right$attrib$class) 18 | 19 | left$attrib$class <- paste(left$attrib$class, left_col_class) 20 | right$attrib$class <- paste(right$attrib$class, right_col_class) 21 | } 22 | 23 | fluidRow(right, left) 24 | } 25 | 26 | col_4 <- function(x) { 27 | tags$div(class = "col-sm-6 col-md-3", style = "min-height: 80px", x) 28 | } -------------------------------------------------------------------------------- /R/edge.R: -------------------------------------------------------------------------------- 1 | # rve$edges is a named list, e.g. for hash(A) -> hash(B): 2 | # rve$edges[edge_key(hash(A), hash(B))] = list(from = hash(A), to = hash(B)) 3 | 4 | # ---- Edge Helper Functions ---- 5 | edge_key <- function(x, y) digest::digest(c(x, y)) 6 | 7 | edge_frame <- function(edges, nodes, ...) { 8 | dots <- rlang::enexprs(...) 9 | 10 | dag_edges <- edges_in_dag(edges, nodes) 11 | 12 | if (!length(dag_edges)) return(tibble()) 13 | 14 | ensure_exists <- function(x, ...) { 15 | cols <- list(...) 16 | stopifnot(!is.null(names(cols)), all(nzchar(names(cols)))) 17 | for (col in names(cols)) { 18 | x[[col]] <- x[[col]] %||% cols[[col]] 19 | } 20 | x %>% tidyr::replace_na(cols) 21 | } 22 | 23 | edges %>% 24 | bind_rows(.id = "hash") %>% 25 | filter(hash %in% edges_in_dag(edges, nodes)) %>% 26 | tidyr::nest(-from) %>% 27 | left_join( 28 | nodes %>% node_frame() %>% select(from = hash, from_name = name), 29 | by = "from" 30 | ) %>% 31 | tidyr::unnest() %>% 32 | tidyr::nest(-to) %>% 33 | left_join( 34 | nodes %>% node_frame() %>% select(to = hash, to_name = name), 35 | by = "to" 36 | ) %>% 37 | tidyr::unnest() %>% 38 | select(hash, names(edges[[1]]), everything()) %>% 39 | ensure_exists(angle = 0L, color = "black", lty = "solid", lineT = "thin") %>% 40 | mutate(!!!dots) 41 | } 42 | 43 | edges_in_dag <- function(edges, nodes) { 44 | if (!length(nodes) || !length(edges)) return(character()) 45 | all_edges <- bind_rows(edges) %>% 46 | mutate(hash = names(edges)) %>% 47 | tidyr::gather(position, node_hash, from:to) 48 | 49 | edges_not_in_graph <- all_edges %>% 50 | filter(!node_hash %in% nodes_in_dag(nodes)) 51 | 52 | setdiff(all_edges$hash, edges_not_in_graph$hash) 53 | } 54 | 55 | edge_edges <- function(edges, nodes, ...) { 56 | do.call(edge, as.list(edge_frame(edges, nodes, ...))) 57 | } 58 | 59 | edge_exists <- function(edges, from_hash = NULL, to_hash = NULL) { 60 | if (purrr::some(list(from_hash, to_hash), is.null)) return(FALSE) 61 | 62 | edges %>% 63 | purrr::keep(~ .$from %in% from_hash) %>% 64 | purrr::keep(~ .$to %in% to_hash) %>% 65 | length() %>% 66 | `>`(0) 67 | } 68 | 69 | edge_points <- function(edges, nodes, push_by = 0) { 70 | dag_edges <- edges_in_dag(edges, nodes) 71 | 72 | if (!length(dag_edges)) return(tibble()) 73 | 74 | edge_frame(edges, nodes) %>% 75 | tidyr::nest(-from) %>% 76 | left_join( 77 | nodes %>% node_frame() %>% select(from = hash, from.x = x, from.y = y), 78 | by = "from" 79 | ) %>% 80 | tidyr::unnest() %>% 81 | tidyr::nest(-to) %>% 82 | left_join( 83 | nodes %>% node_frame() %>% select(to = hash, to.x = x, to.y = y), 84 | by = "to" 85 | ) %>% 86 | tidyr::unnest() %>% 87 | select(hash, names(edges[[1]]), everything()) %>% 88 | mutate( 89 | d_x = to.x - from.x, 90 | d_y = to.y - from.y, 91 | from.x = from.x + push_by * d_x, 92 | from.y = from.y + push_by * d_y, 93 | to.x = to.x - push_by * d_x, 94 | to.y = to.y - push_by * d_y, 95 | color = if_else(color == "", "Black", color) 96 | ) %>% 97 | select(-d_x, -d_y) 98 | } 99 | 100 | edge_toggle <- function(edges, from_hash, to_hash) { 101 | existing <- 102 | edges %>% 103 | purrr::keep(~ .$from == from_hash) %>% 104 | purrr::keep(~ .$to == to_hash) 105 | 106 | if (length(existing)) { 107 | for (edge_key in names(existing)) { 108 | edges[[edge_key]] <- NULL 109 | } 110 | } else { 111 | edges[[edge_key(from_hash, to_hash)]] <- list(from = from_hash, to = to_hash) 112 | } 113 | edges 114 | } 115 | -------------------------------------------------------------------------------- /R/inputs.R: -------------------------------------------------------------------------------- 1 | # A fancy selectizeInput for angles 2 | selectDegree <- function( 3 | inputId, 4 | label = "Degree", 5 | min = -180 + by, 6 | max = 180, 7 | by = 45, 8 | value = 0, 9 | ... 10 | ) { 11 | if (sign(min + (max - min)) != sign(by)) { 12 | by <- -by 13 | } 14 | choices <- seq(min, max, by) 15 | 16 | selectizeInput(inputId, label = label, choices, selected = value, multiple = FALSE, ..., ) 17 | } 18 | 19 | 20 | # A button group that toggles state and optionally allows one button to be active at a time 21 | buttonGroup <- function(inputId, options, btn_class = "btn-default", multiple = FALSE, aria_label = NULL) { 22 | btn_class <- paste("btn", paste(btn_class, collapse = " ")) 23 | button_list <- purrr::imap(options, button_in_group, class = btn_class) 24 | selected <- shiny::restoreInput(inputId, default = "") 25 | tagList( 26 | singleton(tags$head(tags$script(src = "shinythingsButtonGroup.js"))), 27 | tags$div( 28 | class = "shinythings-btn-group btn-group", 29 | id = inputId, 30 | `data-input-id` = inputId, 31 | `data-active` = selected, 32 | `data-multiple` = as.integer(multiple), 33 | role = "group", 34 | button_list 35 | ) 36 | ) 37 | } 38 | 39 | button_in_group <- function(input_id, text, class = "btn btn-default") { 40 | tags$button(id = input_id, class = class, text) 41 | } -------------------------------------------------------------------------------- /R/module/clickpad.R: -------------------------------------------------------------------------------- 1 | clickpad_UI <- function(id, ...) { 2 | library(plotly) 3 | ns <- NS(id) 4 | tagList( 5 | plotlyOutput(ns("plot"), ...) 6 | ) 7 | } 8 | 9 | clickpad_debug <- function(id, relayout = TRUE, doubleclick = TRUE, selected = FALSE, clickannotation = TRUE) { 10 | ns <- NS(id) 11 | col_width <- 12 / sum(relayout, doubleclick, selected, clickannotation) 12 | tagList( 13 | fluidRow( 14 | style = "overflow-y: scroll; max-height: 200px;", 15 | if (relayout) column( 16 | col_width, 17 | tags$p(tags$code("plotly_relayout")), 18 | verbatimTextOutput(ns("v_relayout")) 19 | ), 20 | if (doubleclick) column( 21 | col_width, 22 | tags$p(tags$code("plotly_doubleclick")), 23 | verbatimTextOutput(ns("v_doubleclick")) 24 | ), 25 | if (selected) column( 26 | col_width, 27 | tags$p(tags$code("plotly_selected")), 28 | verbatimTextOutput(ns("v_selected")) 29 | ), 30 | if (clickannotation) column( 31 | col_width, 32 | tags$p(tags$code("plotly_clickannotation")), 33 | verbatimTextOutput(ns("v_clickannotation")) 34 | ) 35 | ) 36 | ) 37 | } 38 | 39 | clickpad <- function( 40 | input, output, session, 41 | nodes, edges, 42 | plotly_source = "clickpad" 43 | ) { 44 | library(plotly) 45 | ns <- session$ns 46 | 47 | node_primary <- reactive({ node_parent(nodes()) }) 48 | node_secondary <- reactive({ node_child(nodes()) }) 49 | node_is_adjusted <- reactive({ node_adjusted(nodes()) }) 50 | node_exposure <- reactive({ names(node_with_attribute(nodes(), "exposure")) }) 51 | node_outcome <- reactive({ names(node_with_attribute(nodes(), "outcome")) }) 52 | 53 | output$v_relayout <- renderPrint({ 54 | str(event_data("plotly_relayout", priority = "event", source = plotly_source)) 55 | }) 56 | 57 | output$v_doubleclick <- renderPrint({ 58 | str(event_data("plotly_doubleclick", priority = "event", source = plotly_source)) 59 | }) 60 | 61 | output$v_selected <- renderPrint({ 62 | str(event_data("plotly_clickannotation", priority = "event", source = plotly_source)) 63 | }) 64 | 65 | output$v_clickannotation <- renderPrint({ 66 | str(event_data("plotly_clickannotation", priority = "event", source = plotly_source)) 67 | }) 68 | 69 | arrow_path <- function(from.x, from.y, to.x, to.y, dist = 0.2, ...) { 70 | # angle of the line between `from` and `to` 71 | theta <- atan2(to.y - from.y, to.x - from.x) 72 | 73 | # push line starting/ending points away from node by a fixed distance 74 | path_points = list( 75 | x0 = from.x + dist * cos(theta), 76 | y0 = from.y + dist * sin(theta), 77 | x1 = to.x - dist * cos(theta), 78 | y1 = to.y - dist * sin(theta) 79 | ) 80 | 81 | # Find points for corners of arrow head (third point is `to`) 82 | arrow_anchor_x = path_points$x1 - dist * cos(theta) 83 | arrow_anchor_y = path_points$y1 - dist * sin(theta) 84 | ad <- 0.1 * dist / tan(1/6 * pi) 85 | 86 | path_points$a1_x = arrow_anchor_x + ad * cos(theta + 1/2 * pi) 87 | path_points$a1_y = arrow_anchor_y + ad * sin(theta + 1/2 * pi) 88 | path_points$a2_x = arrow_anchor_x - ad * cos(theta + 1/2 * pi) 89 | path_points$a2_y = arrow_anchor_y - ad * sin(theta + 1/2 * pi) 90 | 91 | # Draw arrow head in SVG path notation 92 | as.character(glue::glue_data( 93 | path_points, 94 | "M{x0},{y0} L{x1},{y1} L{a1_x},{a1_y} L{a2_x},{a2_y} L{x1},{y1}" 95 | )) 96 | } 97 | 98 | arrows <- reactive({ 99 | if (is.null(edges()) || length(edges()) == 0) return(NULL) 100 | if (is.null(nodes()) || length(nodes()) == 0) return(NULL) 101 | 102 | ep <- edge_points(edges(), nodes()) 103 | if (!nrow(ep)) return(NULL) 104 | 105 | ep %>% 106 | purrr::pmap_chr(arrow_path, dist = 0.2) %>% 107 | purrr::map(~ list( 108 | type = "path", 109 | line = list(color = "#000", width = 1), 110 | fillcolor = "#000", 111 | path = .x, 112 | opacity = 0.75 113 | )) 114 | }) 115 | 116 | create_node_annotations <- function(x, y, name, hash, ...) { 117 | set_color <- function( 118 | default, not_in_dag = NULL, 119 | primary = NULL, secondary = NULL, 120 | exposure = NULL, outcome = NULL, adjusted = NULL, 121 | apply_order = c("primary", "not_in_dag", "adjusted", "exposure", "outcome", "secondary") 122 | ) { 123 | applicable_states <- c( 124 | "primary" = !is.null(node_primary()) && hash %in% node_primary(), 125 | "secondary" = !is.null(node_secondary()) && hash %in% node_secondary(), 126 | "adjusted" = !is.null(node_is_adjusted()) && hash %in% node_is_adjusted(), 127 | "exposure" = !is.null(node_exposure()) && hash %in% node_exposure(), 128 | "outcome" = !is.null(node_outcome()) && hash %in% node_outcome(), 129 | "not_in_dag" = x < 0 130 | ) 131 | 132 | applicable_states <- applicable_states[applicable_states] 133 | if (!length(applicable_states)) return(default) 134 | 135 | applicable_states <- applicable_states[apply_order] 136 | applicable_states <- applicable_states[!is.na(applicable_states)] 137 | if (!length(applicable_states)) return(default) 138 | 139 | color <- switch( 140 | names(applicable_states)[1], 141 | primary = primary, 142 | secondary = secondary, 143 | adjusted = adjusted, 144 | outcome = outcome, 145 | exposure = exposure, 146 | not_in_dag = not_in_dag, 147 | default 148 | ) 149 | 150 | color %||% default 151 | } 152 | 153 | background_color <- set_color( 154 | default = "rgba(255, 255, 255, 0.5)", 155 | not_in_dag = "#FDFDFD", 156 | primary = "rgba(246, 227, 209, 0.75)" 157 | ) 158 | font_color <- set_color( 159 | default = "#000000", 160 | not_in_dag = "#666666", 161 | primary = "#D3751C", 162 | exposure = "#418c7a", 163 | outcome = "#ba2d0b", 164 | apply_order = c("not_in_dag", "exposure", "outcome", "primary") 165 | ) 166 | border_color <- set_color( 167 | default = "#EDEDED", 168 | not_in_dag = "#AAAAAA", 169 | primary = list(NULL), 170 | adjusted = "#1c2d3f", 171 | apply_order = c("not_in_dag", "adjusted", "primary") 172 | ) 173 | 174 | list(text = name, 175 | node_hash = hash, 176 | x = x, 177 | y = y, 178 | font = list(size = 24, color = font_color), 179 | showarrow = FALSE, 180 | align = "center", 181 | captureevents = TRUE, 182 | textposition = "middle center", 183 | bordercolor = border_color, 184 | bgcolor = background_color, 185 | borderpad = 4) 186 | } 187 | 188 | annotations <- reactive({ 189 | if (is.null(nodes()) || length(nodes()) == 0) return(NULL) 190 | nodes() %>% 191 | node_frame(full = TRUE) %>% 192 | purrr::pmap(create_node_annotations) 193 | }) 194 | 195 | left_margin <- list( 196 | type = "rect", 197 | line = list(color = "#AAAAAA", width = 1), 198 | fillcolor = "#EEEEEE", 199 | x0 = -100, 200 | y0 = -100, 201 | x1 = 0, 202 | y1 = 100 203 | ) 204 | 205 | output$plot <- renderPlotly({ 206 | debug_line("rendering clickpad") 207 | redraw_plot() 208 | 209 | ax <- list( 210 | title = "", 211 | zeroline = FALSE, 212 | showline = FALSE, 213 | showticklabels = FALSE, 214 | showgrid = TRUE, 215 | range = list(-1.5, 12.5) 216 | ) 217 | ay <- ax 218 | y_min <- purrr::map_dbl(nodes(), "y") %>% min() 219 | y_max <- purrr::map_dbl(nodes(), "y") %>% max() 220 | ay$range <- list(min(0.5, y_min), max(7.5, y_max)) 221 | 222 | p <- plot_ly(type = "scatter", source = plotly_source) 223 | 224 | p %>% 225 | layout( 226 | annotations = annotations(), 227 | shapes = c(list(left_margin), arrows()), 228 | xaxis = ax, 229 | yaxis = ay 230 | ) %>% 231 | config( 232 | edits = list( 233 | annotationPosition = TRUE 234 | ), 235 | showAxisDragHandles = FALSE 236 | # displayModeBar = FALSE 237 | ) %>% 238 | plotly::event_register("plotly_click") %>% 239 | plotly::event_register("plotly_doubleclick") %>% 240 | plotly::event_register("plotly_selected") %>% 241 | plotly::event_register("plotly_clickannotation") %>% 242 | htmlwidgets::onRender(" 243 | function(el) { 244 | el.on('plotly_hover', function(d) { console.log('Hover: ', d) }); 245 | el.on('plotly_click', function(d) { console.log('Click: ', d) }); 246 | el.on('plotly_selected', function(d) { console.log('Select: ', d) }); 247 | } 248 | ") 249 | }) 250 | 251 | redraw_plot <- reactiveVal(Sys.time()) 252 | 253 | new_coords_lag <- list(hash = NA_character_, x = NA_real_, y = NA_real_) 254 | 255 | new_locations <- reactive({ 256 | req(annotations()) 257 | ## https://stackoverflow.com/questions/54990350/extract-xyz-coordinates-from-draggable-shape-in-plotly-ternary-r-shiny 258 | 259 | event <- event_data("plotly_relayout", source = plotly_source) 260 | if (!length(event)) return() 261 | 262 | annot_event <- event[grepl("^annotations\\[\\d+\\]\\.[xy]$", names(event))] 263 | annot_index <- sub(".+\\[(\\d+)\\].+", "\\1", names(annot_event)[1]) %>% as.integer() 264 | 265 | if (is.na(annot_index) || !is.integer(annot_index)) return() 266 | 267 | 268 | if (length(annotations()) <= annot_index) { 269 | warning("An error occurred, unable to match plotly update to correct node") 270 | return(NULL) 271 | } 272 | 273 | node_hash <- annotations()[[annot_index + 1]]$node_hash 274 | # cli::cat_line("event_name: ", names(event)[1]) 275 | # cli::cat_line("annot_index: ", annot_index) 276 | # cli::cat_line("node_hash: ", node_hash) 277 | 278 | req(!is.null(node_hash)) 279 | 280 | new_x <- annot_event[grepl("\\.x", names(annot_event))] %>% unlist() %>% unname() 281 | new_x <- if (new_x > 0) round(new_x, 0) else new_x 282 | 283 | new_y <- annot_event[grepl("\\.y", names(annot_event))] %>% unlist() %>% unname() 284 | new_y <- if (new_x > 0) round(new_y, 0) else new_y 285 | 286 | i_nodes <- isolate(nodes()) 287 | current_pos <- i_nodes[[node_hash]][c("x", "y")] %>% unlist() %>% unname() 288 | 289 | new_coords <- list( 290 | hash = node_hash, 291 | x = new_x, 292 | y = new_y 293 | ) 294 | 295 | if (identical(c(new_coords$x, new_coords$y), current_pos)) { 296 | # No change in current node position 297 | return() 298 | } 299 | 300 | if (identical(new_coords, new_coords_lag)) { 301 | # The plotly_redraw may not have been a result of annotation position change 302 | return() 303 | } 304 | 305 | new_coords_lag <<- new_coords 306 | 307 | # cli::cat_line("new_x: ", new_x) 308 | # cli::cat_line("new_y: ", new_y) 309 | new_coords 310 | }) 311 | 312 | return(reactive(new_locations())) 313 | } 314 | -------------------------------------------------------------------------------- /R/module/dagPreview.R: -------------------------------------------------------------------------------- 1 | 2 | # UI Function ------------------------------------------------------------- 3 | 4 | dagPreviewUI <- function(id, include_graph_downloads = TRUE, start_hidden = FALSE) { 5 | ns <- shiny::NS(id) 6 | 7 | class_3_col <- "col-md-4 col-md-offset-0 col-sm-8 col-sm-offset-2 col-xs-12" 8 | 9 | download_choices <- c( 10 | "PDF" = "pdf", 11 | "PNG" = "png", 12 | "LaTeX TikZ" = "tikz" 13 | ) 14 | 15 | if (include_graph_downloads) { 16 | download_choices <- c( 17 | download_choices, 18 | "dagitty (R: RDS)" = "dag_dagitty", 19 | "ggdag (R: RDS)" = "dag_tidy" 20 | ) 21 | } 22 | 23 | tagList( 24 | fluidRow( 25 | column( 26 | width = 12, 27 | align = "center", 28 | shinyjs::hidden(tags$div( 29 | id = ns("tikzOut-help"), 30 | class="alert alert-danger", 31 | role="alert", 32 | HTML( 33 | "

An error occurred while compiling the preview.", 34 | "Are there syntax errors in your labels?

", 35 | "

Note that using characters that are", 36 | 'reserved', 37 | 'characters in LaTeX syntax may cause issues. For example,', 38 | "single $ need to be escaped: \\$.

" 39 | ) 40 | )), 41 | tags$div( 42 | class = "dag-preview-tikz", 43 | shinycssloaders::withSpinner(uiOutput(ns("tikzOut")), color = "#C4C4C4", proxy.height = "400px") 44 | ) 45 | ) 46 | ), 47 | fluidRow( 48 | tags$div( 49 | class = class_3_col, 50 | tags$div( 51 | id = ns("showPreviewContainer"), 52 | prettySwitch(ns("showPreview"), "Preview DAG", status = "primary", fill = TRUE, value = !start_hidden) 53 | ) 54 | ), 55 | tags$div( 56 | class = class_3_col, 57 | selectInput( 58 | inputId = ns("downloadType"), 59 | label = "Type of download", 60 | choices = download_choices 61 | ), 62 | uiOutput(ns("downloadType_helptext")) 63 | ), 64 | tags$div( 65 | class = paste(class_3_col, "dagpreview-download-ui"), 66 | div( 67 | class = "btn-group", 68 | role = "group", 69 | id = ns("download-buttons"), 70 | downloadButton(ns("downloadButton")) 71 | ) 72 | ) 73 | ) 74 | ) 75 | } 76 | 77 | 78 | # Server Module ----------------------------------------------------------- 79 | 80 | # This module takes tikz code and creates DAG preview content and returns TRUE 81 | # or FALSE value to track whether the preview is visible. 82 | dagPreview <- function( 83 | input, output, session, 84 | session_dir, 85 | tikz_code, 86 | dag_dagitty = reactive(NULL), 87 | dag_tidy = reactive(NULL), 88 | has_edges = reactive(FALSE) 89 | ) { 90 | ns <- session$ns 91 | SESSION_TEMPDIR <- file.path(session_dir, sub("-$", "", ns(""))) 92 | 93 | tikz_cache_dir <- reactiveVal(NULL) 94 | 95 | # Render tikz preview ---- 96 | observe({ 97 | req(input$showPreview) 98 | 99 | tikz_lines <- tikz_code() 100 | req(gsub("\\s", "", tikz_lines) != "") 101 | debug_input(tikz_lines, ns("tikz_code")) 102 | 103 | useLib <- "\\usetikzlibrary{matrix,arrows,decorations.pathmorphing}" 104 | 105 | pkgs <- paste(buildUsepackage(pkg = list("tikz"), uselibrary = useLib), collapse = "\n") 106 | 107 | tex_dir <- 108 | tex_cached_preview( 109 | session_dir = SESSION_TEMPDIR, 110 | obj = tikz_lines, 111 | stem = "DAGimage", 112 | imgFormat = "png", 113 | returnType = "shiny", 114 | density = tex_opts$get("density"), 115 | keep_pdf = TRUE, 116 | usrPackages = pkgs, 117 | margin = tex_opts$get("margin"), 118 | cleanup = tex_opts$get("cleanup") 119 | ) 120 | tikz_cache_dir(tex_dir) 121 | }, priority = -100) 122 | 123 | # Create tikz preview UI ---- 124 | output$tikzOut <- renderUI({ 125 | req(input$showPreview) 126 | 127 | shiny::validate( 128 | shiny::need( 129 | tryCatch({tikz_code(); TRUE}, error = function(e) FALSE) || 130 | tryCatch(gsub("\\s", "", tikz_code()), error = function(e) "") != "", 131 | paste( 132 | "Nothing to see here... yet. Please use the Sketch tab to create", 133 | "and layout a DAG." 134 | ) 135 | ) 136 | ) 137 | 138 | if (is.null(tikz_cache_dir())) return() 139 | if (!length(tikz_cache_dir())) { 140 | shinyjs::show("tikzOut-help") 141 | return() 142 | } else { 143 | shinyjs::hide("tikzOut-help") 144 | } 145 | 146 | image_path <- file.path(tikz_cache_dir(), "DAGimage.png") 147 | if (!file.exists(image_path)) { 148 | debug_line("Image does not exist: ", image_path) 149 | return() 150 | } 151 | 152 | image_tmp <- tempfile("dag_image_", SESSION_TEMPDIR, ".png") 153 | file.copy(image_path, image_tmp) 154 | debug_line("Serving image: ", image_tmp) 155 | 156 | tags$img( 157 | src = sub("www/", "", image_tmp, fixed = TRUE), 158 | contentType = "image/png", 159 | style = "max-width: 100%; max-height: 600px; -o-object-fit: contain;", 160 | alt = "DAG" 161 | ) 162 | }) 163 | 164 | output$downloadType_helptext <- renderUI({ 165 | is_tikz_download <- input$downloadType %in% c("pdf", "png", "tikz") 166 | if (is_tikz_download && !input$showPreview) { 167 | shinyjs::disable("downloadButton") 168 | return(helpText("Please preview DAG to enable downloads")) 169 | } 170 | 171 | if (!is_tikz_download && !has_edges()) { 172 | shinyjs::disable("downloadButton") 173 | return(helpText("Please add at least one edge to the DAG")) 174 | } 175 | 176 | if (!length(tikz_cache_dir())) { 177 | shinyjs::disable("downloadButton") 178 | return() 179 | } 180 | 181 | shinyjs::enable("downloadButton") 182 | }) 183 | 184 | output$downloadButton <- downloadHandler( 185 | filename = function() { 186 | paste0( 187 | "DAG.", 188 | switch( 189 | input$downloadType, 190 | "dagitty" =, 191 | "ggdag" = "rds", 192 | "tikz" = "tex", 193 | "png" = "png", 194 | "pdf" = "pdf" 195 | ) 196 | ) 197 | }, 198 | content = function(file) { 199 | if (input$downloadType == "pdf") { 200 | 201 | file.copy(file.path(tikz_cache_dir(), "DAGimageDoc.pdf"), file) 202 | 203 | } else if (input$downloadType == "png") { 204 | 205 | file.copy(file.path(tikz_cache_dir(), "DAGimage.png"), file) 206 | 207 | } else if (input$downloadType == "tikz") { 208 | 209 | merge_tex_files( 210 | file.path(tikz_cache_dir(), "DAGimageDoc.tex"), 211 | file.path(tikz_cache_dir(), "DAGimage.tex"), 212 | file 213 | ) 214 | 215 | } else if (input$downloadType == "dag_dagitty") { 216 | 217 | if (is.null(dag_dagitty())) return(NULL) 218 | 219 | saveRDS(dag_dagitty(), file = file) 220 | 221 | } else if (input$downloadType == "dag_tidy") { 222 | 223 | if (is.null(dag_tidy())) return(NULL) 224 | 225 | saveRDS(dag_tidy(), file = file) 226 | } 227 | }, 228 | contentType = NA 229 | ) 230 | 231 | return(reactive(input$showPreview)) 232 | } 233 | 234 | 235 | # Helper Functions -------------------------------------------------------- 236 | 237 | tex_cached_preview <- function(session_dir, ...) { 238 | # Takes arguments for texPreview() except for fileDir 239 | # hashes inputs and then writes preview into session_dir/args_hash 240 | # Skips rendering if the cache already exists 241 | # Returns directory containing the preview documents 242 | 243 | args <- list(...) 244 | args_hash <- digest::digest(args) 245 | 246 | session_token <- basename(dirname(session_dir)) 247 | error_file <- paste0(session_token, "_", args_hash, ".tex") 248 | 249 | cache_dir <- file.path(session_dir, args_hash) 250 | error_dir <- file.path("www", "errors") 251 | 252 | if (dir.exists(cache_dir)) { 253 | return(cache_dir) 254 | } else { 255 | if (file.exists(file.path(error_dir, error_file))) { 256 | # we already know that this tikz code won't work 257 | warning("Bad tikz is still bad: ", error_file) 258 | return(character()) 259 | } 260 | } 261 | 262 | dir.create(cache_dir, recursive = TRUE) 263 | args$fileDir <- cache_dir 264 | tryCatch({ 265 | do.call("texPreview", args) 266 | cache_dir 267 | }, error = function(e) { 268 | # write bad tex code to disk 269 | dir.create(error_dir, showWarnings = FALSE) 270 | cat( 271 | args$obj, 272 | sep = "\n", 273 | file = file.path(error_dir, error_file) 274 | ) 275 | unlink(cache_dir, recursive = TRUE) 276 | character() 277 | }) 278 | } 279 | 280 | # Merge tikz TeX source into main TeX file 281 | merge_tex_files <- function(main_file, input_file, out_file) { 282 | x <- readLines(main_file) 283 | y <- readLines(input_file) 284 | which_line <- grep("input{", x, fixed = TRUE) 285 | which_line <- intersect(which_line, grep(basename(input_file), x)) 286 | x[which_line] <- paste(y, collapse = "\n") 287 | writeLines(x, out_file) 288 | } 289 | -------------------------------------------------------------------------------- /R/module/examples.R: -------------------------------------------------------------------------------- 1 | add_slug <- function(ex) { 2 | ex %>% 3 | purrr::map(~ { 4 | .x$slug <- gsub("[.]rds$", "", .x$file, ignore.case = TRUE) 5 | .x 6 | }) 7 | } 8 | 9 | keep_ex_with_file <- function(ex) { 10 | ex %>% 11 | purrr::keep(~ file.exists(.$file)) 12 | } 13 | 14 | nullify_missing <- function(ex, field = "image") { 15 | ex %>% 16 | purrr::modify_depth( 17 | .depth = 1, 18 | ~ purrr::modify_at(., field, ~ { 19 | if (!file.exists(.x)) list(NULL) else .x 20 | }) 21 | ) 22 | } 23 | 24 | full_path <- function(ex, field, path = file.path("www", "examples")) { 25 | ex %>% 26 | purrr::modify_depth( 27 | .depth = 1, 28 | ~ purrr::modify_at(., field, ~ file.path(path, .x)) 29 | ) 30 | } 31 | 32 | rel_path <- function(ex, field, path = file.path("www/")) { 33 | ex %>% 34 | purrr::modify_depth( 35 | .depth = 1, 36 | ~ purrr::modify_at(., field, ~ if (!is.null(.x)) sub(path, "", .x, fixed = TRUE) else list(NULL)) 37 | ) 38 | } 39 | 40 | load_example_values <- function(ex) { 41 | purrr::map(ex, ~ { 42 | values <- readRDS(.x$file) 43 | .x$values <- list() 44 | .x$values$nodes <- values$rvn$nodes 45 | .x$values$edges <- values$rve$edges 46 | .x 47 | }) 48 | } 49 | 50 | load_examples <- function(path = file.path("www", "examples")) { 51 | ex_yaml <- file.path(path, "examples.yml") 52 | if (!file.exists(ex_yaml)) { 53 | stop("Unable to locate ", ex_yaml) 54 | } 55 | 56 | ex <- yaml::read_yaml(ex_yaml) 57 | 58 | ex %>% 59 | add_slug() %>% 60 | full_path("image", path) %>% 61 | full_path("file", path) %>% 62 | keep_ex_with_file() %>% 63 | nullify_missing("image") %>% 64 | rel_path("image") %>% 65 | load_example_values() 66 | } 67 | 68 | 69 | EXAMPLES <- load_examples() 70 | 71 | examples_UI <- function(id) { 72 | ns <- NS(id) 73 | 74 | make_examples_ui <- function(name, description, slug, image = NULL, ...) { 75 | tagList( 76 | tags$h3(name), 77 | if (!is.null(image)) tags$div( 78 | class = "example-image", 79 | tags$img(src = image) 80 | ), 81 | tags$p( 82 | HTML(description) 83 | ), 84 | actionButton(ns(slug), "Load Example") 85 | ) 86 | } 87 | 88 | tagList( 89 | EXAMPLES %>% 90 | purrr::map(`[`, c("name", "description", "slug", "image")) %>% 91 | purrr::map(~ purrr::pmap(.x, make_examples_ui)) 92 | ) 93 | } 94 | 95 | examples <- function(input, output, session) { 96 | input_ids <- EXAMPLES %>% purrr::map_chr("slug") 97 | values <- EXAMPLES %>% purrr::map("values") 98 | names(values) <- input_ids 99 | 100 | lagged_value <- setNames(rep(0L, length(input_ids)), input_ids) 101 | 102 | example_value <- reactiveVal(NULL) 103 | 104 | observe({ 105 | current_btn_vals <- purrr::map_int(input_ids, ~ input[[.x]]) 106 | req(any(current_btn_vals > 0L)) 107 | # cli::cat_line("lagged: ", lagged_value) 108 | # cli::cat_line("current: ", current_btn_vals) 109 | 110 | idx <- which(current_btn_vals != lagged_value) 111 | lagged_value <<- current_btn_vals 112 | 113 | if (!length(idx)) { 114 | example_value(NULL) 115 | return(NULL) 116 | } 117 | 118 | changed_input <- input_ids[idx] 119 | 120 | example_value(values[[changed_input]]) 121 | }) 122 | 123 | return(reactive(example_value())) 124 | } 125 | 126 | 127 | # ui <- fluidPage( 128 | # examples_UI("example") 129 | # ) 130 | # server <- function(input, output, session){ 131 | # callModule(examples, 'example') 132 | # } 133 | # shinyApp(ui, server) -------------------------------------------------------------------------------- /R/node.R: -------------------------------------------------------------------------------- 1 | # ---- Node Helper Functions ---- 2 | node_new <- function(nodes, hash, name, gap_y = 0.75, min_y = 1) { 3 | # new nodes are added into the clickpad area but with x = -0.75 4 | # need to check if there are other nodes in the holding space and adjust y 5 | taken_y <- nodes %>% purrr::keep(~ !is.na(.$y)) %>% purrr::map_dbl(`[[`, "y") 6 | new_y <- find_new_y(taken_y, gap_y, min_y) 7 | nodes[[hash]] <- list(name = name, x = -0.75, y = new_y) 8 | nodes 9 | } 10 | 11 | find_new_y <- function(y, gap_y = 0.75, min_y = 0.5) { 12 | if (!length(y)) return(min_y) 13 | if (min(y) >= (min_y + gap_y)) return(min_y) 14 | if (length(y) == 1) return(y + gap_y) 15 | 16 | y <- sort(y) 17 | 18 | gap_size <- c(lead(y) - y)[-length(y)] 19 | if (any(gap_size >= 2 * gap_y)) { 20 | first_gap <- which(gap_size > 2 * gap_y)[1] 21 | return(y[first_gap] + gap_y) 22 | } 23 | 24 | max(y) + gap_y 25 | } 26 | 27 | node_name_valid <- function(nodes, name, warn = FALSE) { 28 | if (!nzchar(name)) { 29 | warnNotification("Please specify a name for the node") 30 | return(FALSE) 31 | } 32 | name_in_nodes <- vapply(nodes, function(n) name == n$name, FALSE) 33 | if (any(name_in_nodes)) { 34 | if (warn) warnNotification('"', name, '" is already the name of a node') 35 | FALSE 36 | } else { 37 | TRUE 38 | } 39 | } 40 | 41 | node_names <- function(nodes, all = FALSE) { 42 | if (!length(nodes)) { 43 | return(character()) 44 | } 45 | x <- invertNames(sapply(nodes, function(x) x$name)) 46 | if (all) { 47 | return(x) 48 | } 49 | in_dag <- sapply(nodes, function(n) n$x >= 0) 50 | x[in_dag] 51 | } 52 | 53 | node_name_from_hash <- function(nodes, hash) { 54 | invertNames(node_names(nodes))[hash] 55 | } 56 | 57 | node_update <- function(nodes, hash, name = NULL, x = NULL, y = NULL, name_latex = NULL) { 58 | # in general update a property if arg is not null, default to current value 59 | nodes[[hash]]$name <- name %||% nodes[[hash]]$name 60 | nodes[[hash]]$x <- x %||% nodes[[hash]]$x 61 | nodes[[hash]]$y <- y %||% nodes[[hash]]$y 62 | # for name_latex precedence is arg > name (arg) > existing > name (existing) 63 | nodes[[hash]]$name_latex <- name_latex %||% ( 64 | (name %??% name) %>% escape_quotes() %>% escape_latex() 65 | ) %||% nodes[[hash]]$name_latex %||% ( 66 | (nodes[[hash]]$name %??% nodes[[hash]]$name) %>% escape_quotes() %>% escape_latex() 67 | ) 68 | nodes 69 | } 70 | 71 | node_set_attribute <- function(nodes, hash, attribs) { 72 | for (node in names(nodes)) { 73 | for (attrib in attribs) { 74 | nodes[[node]][[attrib]] <- node %in% hash 75 | } 76 | } 77 | nodes 78 | } 79 | 80 | node_unset_attribute <- function(nodes, hashes, attribs) { 81 | for (hash in hashes) { 82 | for (attrib in attribs) { 83 | nodes[[hash]][[attrib]] <- FALSE 84 | } 85 | } 86 | nodes 87 | } 88 | 89 | node_with_attribute <- function(nodes, attrib) { 90 | if (length(nodes) == 0) return(NULL) 91 | n <- nodes %>% 92 | purrr::map(attrib) %>% 93 | purrr::keep(isTRUE) 94 | if (length(n)) n 95 | } 96 | 97 | node_parent <- function(nodes) { 98 | names(node_with_attribute(nodes, "parent")) 99 | } 100 | 101 | node_child <- function(nodes) { 102 | names(node_with_attribute(nodes, "child")) 103 | } 104 | 105 | node_adjusted <- function(nodes) { 106 | names(node_with_attribute(nodes, "adjusted")) 107 | } 108 | 109 | node_exposure <- function(nodes) { 110 | names(node_with_attribute(nodes, "exposure")) 111 | } 112 | 113 | node_outcome <- function(nodes) { 114 | names(node_with_attribute(nodes, "outcome")) 115 | } 116 | 117 | node_delete <- function(nodes, hash) { 118 | .nodes <- nodes[setdiff(names(nodes), hash)] 119 | if (length(.nodes)) .nodes else list() 120 | } 121 | 122 | node_frame <- function(nodes, full = FALSE) { 123 | if (!length(nodes)) { 124 | return(tibble()) 125 | } 126 | x <- bind_rows(nodes) %>% 127 | mutate(hash = names(nodes)) %>% 128 | select(hash, everything()) %>% 129 | mutate(visible = !is.na(x), in_dag = x > 0) %>% 130 | node_frame_complete() 131 | if (full) { 132 | return(x) 133 | } 134 | filter(x, in_dag) 135 | } 136 | 137 | node_frame_complete <- function(nodes) { 138 | nodes$adjusted <- nodes[["adjusted"]] %||% FALSE 139 | nodes$color_draw <- nodes[["color_draw"]] %||% "Black" 140 | nodes$color_fill <- nodes[["color_fill"]] %||% "White" 141 | nodes$color_text <- nodes[["color_text"]] %||% "Black" 142 | nodes 143 | } 144 | 145 | node_vertices <- function(nodes) { 146 | v_df <- node_frame(nodes) 147 | vertices( 148 | name = v_df$name, 149 | x = v_df$x, 150 | y = v_df$y, 151 | hash = v_df$hash 152 | ) 153 | } 154 | 155 | node_nearest <- function(nodes, coordinfo, threshold = 0.5) { 156 | nodes %>% 157 | node_frame() %>% 158 | mutate(dist = (x - coordinfo$x)^2 + (y - coordinfo$y)^2) %>% 159 | arrange(dist) %>% 160 | filter(dist <= threshold) %>% 161 | slice(1) %>% 162 | select(-dist) 163 | } 164 | 165 | nodes_in_dag <- function(nodes, include_staged = FALSE) { 166 | n <- nodes %>% 167 | purrr::keep(~ !is.na(.$x)) 168 | 169 | if (!include_staged) { 170 | n <- purrr::keep(n, ~ .$x > 0) 171 | } 172 | names(n) 173 | } 174 | 175 | node_btn_id <- function(node_hash) paste0("node_toggle_", node_hash) 176 | node_btn_get_hash <- function(node_btn_id) sub("node_toggle_", "", node_btn_id, fixed = TRUE) 177 | 178 | node_tikz_style <- function(hash, adjusted, color_draw, color_fill, color_text, ...) { 179 | # B/.style={fill=DarkRed, text=White} 180 | if (!adjusted && color_fill == "White" && color_text == "Black") { 181 | return(NA_character_) 182 | } 183 | style <- 184 | list( 185 | draw = if (adjusted) color_draw, 186 | fill = color_fill, 187 | text = color_text 188 | ) %>% 189 | purrr::compact() %>% 190 | purrr::imap_chr(~ glue::glue("{.y}={.x}")) %>% 191 | paste(collapse = ", ") 192 | 193 | glue::glue("{hash}/.style={{{style}}}") 194 | } 195 | 196 | node_frame_add_style <- function(nodes) { 197 | if (!"name_latex" %in% names(nodes)) nodes$name_latex <- "" 198 | nodes <- node_frame_replace_default(nodes) 199 | nodes %>% 200 | mutate( 201 | tikz_style = purrr::pmap_chr(nodes, node_tikz_style), 202 | name_latex = case_when( 203 | is.na(name_latex) | name_latex == "" ~ escape_latex(name), 204 | TRUE ~ name_latex 205 | ), 206 | tikz_node = case_when( 207 | !is.na(tikz_style) ~ paste(glue::glue("|[{hash}]| {name_latex}")), 208 | TRUE ~ name_latex 209 | ) 210 | ) 211 | } 212 | 213 | node_frame_replace_default <- function(nodes) { 214 | tidyr::replace_na(nodes, list( 215 | child = FALSE, 216 | exposure = FALSE, 217 | outcome = FALSE, 218 | adjusted = FALSE, 219 | name_latex = "", 220 | visible = FALSE, 221 | in_dag = FALSE, 222 | color_draw = "Black", 223 | color_fill = "White", 224 | color_text = "Black" 225 | )) 226 | } 227 | 228 | escape_quotes <- function(x) { 229 | x %??% gsub("(['\"])", "\\\\\\1", x) 230 | } 231 | 232 | escape_latex <- function(x, force = FALSE) { 233 | if (is.null(x)) return(NULL) 234 | if (!force && grepl("$", x, fixed = TRUE)) { 235 | # has at least one dollar sign so we'll try to parse out the math 236 | x_math <- chunk_math(x) 237 | is_math <- attr(x_math, "is_math") 238 | if (is.null(is_math) || !any(is_math)) { 239 | # no math, just escape the original string 240 | return(escape_latex(x, force = TRUE)) 241 | } 242 | x_math[!is_math] <- x_math[!is_math] %>% 243 | purrr::map_chr(escape_latex, force = TRUE) 244 | 245 | return(paste0(x_math, collapse = "")) 246 | } 247 | 248 | ## escape: # $ % ^ & _ { } 249 | ## replace: ~ -> \~{} 250 | ## replace: \ -> \textbackslash 251 | ## replace: < > -> \textless \textgreater 252 | x <- gsub("\\", "\\textbackslash ", x, fixed = TRUE) 253 | x <- gsub("<", "\\textless ", x, fixed = TRUE) 254 | x <- gsub(">", "\\textgreater ", x, fixed = TRUE) 255 | x <- gsub("([#$%^&_{}])", "\\\\\\1", x) 256 | x <- gsub("~", "\\~{}", x, fixed = TRUE) 257 | x 258 | } 259 | 260 | chunk_math <- function(x) { 261 | x_s <- strsplit(x, character())[[1]] 262 | 263 | idx <- which(grepl("$", x_s, fixed = TRUE)) 264 | if (!length(idx)) { 265 | return(x) 266 | } 267 | # remove \\$ pairs from indexes 268 | idx_has_escape <- which(grepl("\\", x_s[idx[idx > 1L] - 1L], fixed = TRUE)) 269 | if (length(idx_has_escape)) { 270 | idx <- idx[-(idx_has_escape + as.integer(any(idx == 1)))] 271 | } 272 | 273 | # only include $ that touch at least one alphanum character 274 | x_around_dollar <- purrr::map_chr(idx, ~ { 275 | substr(x, max(0, .x - 1, na.rm = TRUE), min(nchar(x), .x + 1)) 276 | }) 277 | idx_no_adjacent_alpha <- which(!grepl("[[:alnum:]+=*{}.-]", x_around_dollar)) 278 | if (length(idx_no_adjacent_alpha)) { 279 | idx <- idx[-idx_no_adjacent_alpha] 280 | } 281 | if (!length(idx)) { 282 | return(x) 283 | } 284 | 285 | # finally, find the math chunks 286 | chunks <- c() 287 | is_math <- c() 288 | i <- 1L 289 | while (i < length(idx)) { 290 | # idx[i - 1] ... idx[i]-1 -> not math 291 | # idx[i]...idx[i+1] -> math 292 | # skip ahead to idx[i + 2] 293 | idx_not_math <- max(idx[i-1], 0, na.rm = TRUE) 294 | chunks <- c( 295 | chunks, 296 | if (idx_not_math != idx[i] - 1L) substr(x, idx_not_math, idx[i] - 1L), 297 | substr(x, idx[i], idx[i + 1]), 298 | if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) { 299 | substr(x, idx[i + 1] + 1, nchar(x)) 300 | } 301 | ) 302 | is_math <- c( 303 | is_math, 304 | if (idx_not_math != idx[i] - 1L) FALSE, 305 | TRUE, 306 | if (is.na(idx[i + 2]) & !idx[i + 1] == nchar(x)) FALSE 307 | ) 308 | i <- i + 2L 309 | } 310 | 311 | attributes(chunks)$is_math <- is_math 312 | chunks 313 | } 314 | -------------------------------------------------------------------------------- /R/tests/test-escape_latex.R: -------------------------------------------------------------------------------- 1 | source("../node.R") 2 | 3 | latex_text <- list( 4 | list(t = "$m^2$", e = "$m^2$"), 5 | list(t = "a $m^2$", e = "a $m^2$"), 6 | list(t = "$m^2$ b", e = "$m^2$ b"), 7 | list(t = "a $m^2$ b", e = "a $m^2$ b"), 8 | list(t = "a $e=$$m^2$ b", e = "a $e=$$m^2$ b"), 9 | list(t = "a $$ math", e = "a \\$\\$ math"), 10 | list(t = "\\textbackslash", e = "\\textbackslash textbackslash"), 11 | list(t = "# of", e = "\\# of"), 12 | list(t = "$ amount", e = "\\$ amount"), 13 | list(t = "my $$ is", e = "my \\$\\$ is"), 14 | list(t = "$m $$ m$", e = "$m $$ m$"), 15 | list(t = "$$ is $mc^2$", e = "\\$\\$ is $mc^2$"), 16 | list(t = "a > b", e = "a \\textgreater b"), #<< extra space before b 17 | list(t = "a < b", e = "a \\textless b"), #<< same 18 | list(t = "a % b", e = "a \\% b"), 19 | list(t = "a_b", e = "a\\_b"), 20 | list(t = "a & b", e = "a \\& b"), 21 | list(t = "a & b \\ c", e = "a \\& b \\textbackslash c"), #<< + space 22 | list(t = "{a}", e = "\\{a\\}"), 23 | list(t = "a ~ b", e = "a \\~{} b") 24 | ) 25 | 26 | passed_test <- purrr::map_lgl(latex_text, function(x) { 27 | identical(escape_latex(x$t), x$e) 28 | }) 29 | 30 | if (all(passed_test)) { 31 | cat('\nAll (', sum(passed_test), ') tests passed!', sep = '') 32 | } else { 33 | cat('\nThere were', sum(!passed_test), "failures...") 34 | purrr::walk(latex_text[!passed_test], function(x) { 35 | cat("\n'", x$t, "' returned '", escape_latex(x$t), "' not '", x$e, "'", sep = "") 36 | }) 37 | } 38 | -------------------------------------------------------------------------------- /R/xcolorPicker.R: -------------------------------------------------------------------------------- 1 | # xcolors list ---- 2 | 3 | if (!file.exists(file.path("data", "xcolors.csv"))) { 4 | if (!dir.exists('data')) { 5 | stop("Not sure where I am") 6 | } 7 | message("Getting xcolors color list") 8 | read_gz <- function(x) readLines(gzcon(url(x))) 9 | 10 | xcolors <- 11 | list( 12 | # x11 = "http://www.ukern.de/tex/xcolor/tex/x11nam.def.gz", 13 | svg = "http://www.ukern.de/tex/xcolor/tex/svgnam.def.gz" 14 | ) %>% 15 | purrr::map(read_gz) %>% 16 | purrr::flatten_chr() %>% 17 | stringr::str_subset("^(%%|\\\\| )", negate = TRUE) %>% 18 | stringr::str_remove("(;%|\\})$") %>% 19 | readr::read_csv(col_names = c("color", "r", "g", "b")) %>% 20 | arrange(color) %>% 21 | readr::write_csv(file.path("data", "xcolors.csv")) 22 | } else { 23 | xcolors <- 24 | file.path("data/xcolors.csv") %>% 25 | read.csv(stringsAsFactors = FALSE) 26 | } 27 | 28 | # Color Functions ---- 29 | 30 | choose_dark_or_light <- function(x, black = "#000000", white = "#FFFFFF") { 31 | # x = color_hex 32 | color_rgb <- col2rgb(x)[, 1] 33 | # from https://stackoverflow.com/a/3943023/2022615 34 | color_rgb <- color_rgb / 255 35 | color_rgb[color_rgb <= 0.03928] <- color_rgb[color_rgb <= 0.03928]/12.92 36 | color_rgb[color_rgb > 0.03928] <- ((color_rgb[color_rgb > 0.03928] + 0.055)/1.055)^2.4 37 | lum <- t(c(0.2126, 0.7152, 0.0722)) %*% color_rgb 38 | if (lum[1, 1] > 0.179) eval(black) else eval(white) 39 | } 40 | 41 | xcolor_style <- function(hex, text, ...) { 42 | glue::glue('background-color:{hex};color:{text}') 43 | } 44 | 45 | # Prep Color List ---- 46 | 47 | xcolors <- 48 | xcolors %>% 49 | mutate( 50 | hex = rgb(r, g, b, maxColorValue = 1), 51 | text = purrr::map_chr(hex, choose_dark_or_light) 52 | ) %>% 53 | select(color, hex, text) 54 | 55 | 56 | xcolors_list <- xcolors$color 57 | names(xcolors_list) <- purrr::pmap_chr(xcolors, xcolor_style) 58 | 59 | xcolor_label <- function(value) { 60 | xcolors %>% filter(color == value) %>% purrr::pmap_chr(xcolor_style) 61 | } 62 | 63 | # xcolorPicker() ---- 64 | 65 | xcolorPicker <- function(inputId, label = NULL, selected = NULL, ...) { 66 | selectizeInput( 67 | inputId, 68 | label = label, 69 | choices = c("", xcolors_list), 70 | multiple = FALSE, 71 | selected = selected, 72 | options = list( 73 | searchField = "value", 74 | render = I( 75 | '{ 76 | item: (item, escape) => `
${escape(item.value)}
`, 77 | option: (item, escape) => `
${escape(item.value)}
` 78 | }' 79 | )) 80 | ) 81 | } -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # shinyDAG 2 | 3 | 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 effects1-4. The web-based application can be accessed at [https://apps.gerkelab.com/shinyDAG/](https://apps.gerkelab.com/shinyDAG/). 4 | 5 | ## Key operations 6 | 7 | ### Adding nodes and edges 8 | 9 | ![Alt Text](Figures/AddNodeEdge.gif) 10 | 11 | ### Editing DAG aesthetics 12 | 13 | ![Alt Text](Figures/editEdge.gif) 14 | 15 | ## Examplary usage 16 | 17 | The following DAG was reproduced from "A structural approach to selection bias"5 (Figure 6A) using the shinyDAG web app. 18 | 19 | ![alt text](Figures/example1.png "Hernan Example") 20 | 21 | For comparison, the DAG from the original article is shown below. 22 | 23 | ![alt text](Figures/example1_hernan.png "Hernan Original") 24 | 25 | 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. 26 | 27 | ![alt text](Figures/paths.png "shinyDAG path output") 28 | 29 | 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. 30 | 31 | ![alt text](Figures/paths2.png "shinyDAG final path output") 32 | 33 | ## Other features 34 | 35 | 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. 36 | 37 | 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. 38 | 39 | ## Citing shinyDAG 40 | 41 | shinyDAG was developed by Jordan Creed, Garrick Aden-Buie and Travis Gerke. 42 | 43 | Concept DOI: 10.5281/zenodo.1288712 44 | 45 | v0.1.0 DOI: 10.5281/zenodo.1296477 46 | 47 | v0.0.0 DOI: 10.5281/zenodo.1288713 48 | 49 | ## References 50 | 51 | 1. Richard Iannone (NA). DiagrammeR: Graph/Network Visualization. R package version 1.0.0. 52 | [https://github.com/rich-iannone/DiagrammeR](https://github.com/rich-iannone/DiagrammeR). 53 | 1. Johannes Textor and Benito van der Zander (2016). dagitty: Graphical Analysis of Structural Causal 54 | Models. R package version 0.2-2. [https://CRAN.R-project.org/package=dagitty](https://CRAN.R-project.org/package=dagitty). 55 | 1. Malcolm Barrett (2018). ggdag: Analyze and Create Elegant Directed Acyclic Graphs. R package 56 | version 0.1.0. [https://CRAN.R-project.org/package=ggdag](https://CRAN.R-project.org/package=ggdag). 57 | 1. Csardi G, Nepusz T: The igraph software package for complex network research, InterJournal, 58 | Complex Systems 1695. 2006. [http://igraph.org](http://igraph.org). 59 | 1. Hernan MA, Hernandez-Díaz S, Robins JM. A structural approach to selection bias. Epidemiology 2004;15:615-625. 60 | -------------------------------------------------------------------------------- /VERSION: -------------------------------------------------------------------------------- 1 | 1.0.0 2 | -------------------------------------------------------------------------------- /data/xcolors.csv: -------------------------------------------------------------------------------- 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 153 | -------------------------------------------------------------------------------- /dev/Dockerfile: -------------------------------------------------------------------------------- 1 | # shiny-verse:3.6.0 2 | FROM rocker/verse:3.5.3 3 | 4 | LABEL maintainer="Travis Gerke (Travis.Gerke@moffitt.org)" 5 | 6 | # Install system dependencies for required packages 7 | RUN apt-get update -qq && apt-get -y --no-install-recommends install \ 8 | libssl-dev \ 9 | libxml2-dev \ 10 | libmagick++-dev \ 11 | libv8-3.14-dev \ 12 | libglu1-mesa-dev \ 13 | freeglut3-dev \ 14 | mesa-common-dev \ 15 | libudunits2-dev \ 16 | libpoppler-cpp-dev \ 17 | libwebp-dev \ 18 | && apt-get clean \ 19 | && rm -rf /var/lib/apt/lists/ \ 20 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 21 | 22 | RUN install2.r --error --deps TRUE \ 23 | shinyAce \ 24 | shinydashboard \ 25 | shinyWidgets \ 26 | DiagrammeR \ 27 | ggdag \ 28 | igraph \ 29 | pdftools \ 30 | shinyBS \ 31 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 32 | 33 | RUN Rscript -e "devtools::install_github('metrumresearchgroup/texPreview', ref = 'e954322')" \ 34 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 35 | 36 | # Install TinyTeX 37 | RUN install2.r --error tinytex \ 38 | && export CTAN_REPO="http://mirror.las.iastate.edu/tex-archive/systems/texlive/tlnet" \ 39 | && wget -qO- \ 40 | "https://github.com/yihui/tinytex/raw/master/tools/install-unx.sh" | \ 41 | sh -s - --admin --no-path \ 42 | && mv ~/.TinyTeX /opt/TinyTeX \ 43 | && /opt/TinyTeX/bin/*/tlmgr path add \ 44 | && tlmgr update --self \ 45 | && tlmgr install metafont mfware inconsolata tex ae parskip listings \ 46 | && tlmgr install standalone varwidth xcolor colortbl multirow psnfss setspace pgf \ 47 | && tlmgr path add \ 48 | && Rscript -e "tinytex::r_texmf()" \ 49 | && chown -R root:staff /opt/TinyTeX \ 50 | && chmod -R a+w /opt/TinyTeX \ 51 | && chmod -R a+wx /opt/TinyTeX/bin \ 52 | && echo "PATH=${PATH}" >> /usr/local/lib/R/etc/Renviron \ 53 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 54 | 55 | RUN install2.r --error --deps TRUE shinyjs \ 56 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 57 | 58 | RUN install2.r --error plotly \ 59 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 60 | 61 | RUN install2.r --error shinycssloaders \ 62 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 63 | 64 | ARG TRIGGER_UPDATE=unknown 65 | RUN installGithub.r gadenbuie/grkstyle r-lib/styler 66 | 67 | RUN installGithub.r gadenbuie/shinyThings@4e8becb2972aa2f7f1960da6e5fe6ad39aeceda0 \ 68 | && rm -rf /tmp/downloaded_packages/ /tmp/*.rds 69 | 70 | #ARG SHINY_APP_IDLE_TIMEOUT=600 71 | #RUN sed -i "s/directory_index on;/app_idle_timeout ${SHINY_APP_IDLE_TIMEOUT};/g" /etc/shiny-server/shiny-server.conf 72 | #COPY . /srv/shiny-server/shinyDAG 73 | #RUN chown -R shiny:shiny /srv/shiny-server/ 74 | -------------------------------------------------------------------------------- /dev/README.md: -------------------------------------------------------------------------------- 1 | ## Building and developing shinyDAG 2 | 3 | ### shinyDAG dev environment 4 | 5 | I use the Dockerfile in this folder to create a fully-featured RStudio docker container that is *pretty close* to the final shinyDAG environment. 6 | 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). 7 | 8 | To create the dev environment: 9 | 10 | ```bash 11 | # make sure you're in the ./dev folder 12 | cd dev 13 | 14 | # make the dev image 15 | docker build -t shinydag-dev . 16 | 17 | # move back to shinyDAG proper and start up the dev image 18 | cd .. 19 | docker run --rm -d -p 8787:8787 -v $(pwd):/home/rstudio/shinydag -e PASSWORD="password" shinydag-dev 20 | ``` 21 | 22 | (Note that you should probably change the password above, but if you're only running locally it's not a big deal.) 23 | 24 | Then navigate to and login using the password you entered. 25 | 26 | ### Create shinyDAG image 27 | 28 | ```bash 29 | docker build -t gerkelab/shinydag:dev . 30 | 31 | # To send up to docker hub 32 | docker push 33 | ``` 34 | 35 | The `:dev` indicates that this image is tagged `dev`, but this can be anything you want. 36 | 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. 37 | -------------------------------------------------------------------------------- /global.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinydashboard) 3 | library(DiagrammeR) 4 | library(dagitty) 5 | library(igraph) 6 | library(texPreview) 7 | library(shinyAce) 8 | library(shinyBS) 9 | library(dplyr) 10 | library(ggdag) 11 | library(shinyWidgets) 12 | library(shinyjs) 13 | library(shinycssloaders) 14 | library(shinyThings) 15 | source("R/node.R") 16 | source("R/edge.R") 17 | source("R/columns.R") 18 | source("R/module/clickpad.R") 19 | source("R/module/dagPreview.R") 20 | source("R/module/examples.R") 21 | source("R/xcolorPicker.R") 22 | source("R/aes_ui.R") 23 | # Additional libraries: tidyr, digest, rlang 24 | 25 | enableBookmarking(store = "server") 26 | 27 | tex_opts$set(list( 28 | density = 1200, 29 | margin = list(left = 0, top = 0, right = 0, bottom = 0), 30 | cleanup = c("aux", "log") 31 | )) 32 | 33 | 34 | 35 | # Functions --------------------------------------------------------------- 36 | 37 | DEBUG <- getOption("shinydag.debug", FALSE) 38 | debug_input <- function(x, x_name = NULL) { 39 | if (!isTRUE(DEBUG)) return() 40 | 41 | if (is.null(x)) { 42 | cat(if (!is.null(x_name)) paste0(x_name, ":"), "NULL", "\n") 43 | } else if (inherits(x, "igraph")) { 44 | cat(capture.output(print(x)), "", sep = "\n") 45 | } else if (length(x) == 1 && !is.list(x)) { 46 | cat(if (!is.null(x_name)) paste0(x_name, ":"), if (length(names(x))) names(x), "-", x, "\n") 47 | } else if (is.list(x) && length(x) == 0) { 48 | cat(if (!is.null(x_name)) paste0(x_name, ":"), "list()", "\n") 49 | } else { 50 | if (!inherits(x, "data.frame")) x <- tibble::enframe(x) 51 | cat(if (!is.null(x_name)) paste0(x_name, ":"), knitr::kable(x), "", sep = "\n") 52 | } 53 | } 54 | debug_line <- function(...) { 55 | if (!isTRUE(DEBUG)) return() 56 | cli::cat_line(...) 57 | } 58 | 59 | 60 | buildUsepackage <- if (length(find("build_usepackage"))) texPreview::build_usepackage else texPreview::buildUsepackage 61 | 62 | # use y if x is.null 63 | `%||%` <- function(x, y) if (is.null(x)) y else x 64 | # use y if x is not null(ish) (otherwise NULL) 65 | `%??%` <- function(x, y) if (!is.null(x) && x != "") y 66 | 67 | warnNotification <- function(...) showNotification( 68 | paste0(...), duration = 5, closeButton = TRUE, type = "warning" 69 | ) 70 | 71 | invertNames <- function(x) setNames(names(x), unname(x)) 72 | 73 | # String utilities ---- 74 | 75 | str_and <- function(...) { 76 | x <- c(...) 77 | last <- if (length(x) > 2) ", and " else " and " 78 | glue::glue_collapse(x, sep = ", ", last = last) 79 | } 80 | 81 | str_plural <- function(x, word, plural = paste0(word, "s")) { 82 | if (length(x) > 1) plural else word 83 | } 84 | -------------------------------------------------------------------------------- /server.R: -------------------------------------------------------------------------------- 1 | 2 | # Server ------------------------------------------------------------------ 3 | server <- function(input, output, session) { 4 | # ---- Global - Debug ---- 5 | observeEvent(input$debug_browse, { 6 | browser() 7 | }) 8 | 9 | # ---- Global - Session Temp Directory ---- 10 | SESSION_TEMPDIR <- file.path("www", session$token) 11 | dir.create(SESSION_TEMPDIR, showWarnings = FALSE) 12 | onStop(function() { 13 | message("Removing session tempdir: ", SESSION_TEMPDIR) 14 | unlink(SESSION_TEMPDIR, recursive = TRUE) 15 | }) 16 | message("Using session tempdir: ", SESSION_TEMPDIR) 17 | 18 | # ---- Global - Bookmarking ---- 19 | onBookmark(function(state) { 20 | state$values$rvn <- list() 21 | state$values$rvn$nodes <- rvn$nodes 22 | state$values$rve <- list() 23 | state$values$rve$edges <- rve$edges 24 | state$values$query_string <- session$clientData$url_search 25 | 26 | # Store outcome/exposure/adjust node selections 27 | state$values$sel <- list( 28 | exposureNode = input$exposureNode, 29 | outcomeNode = input$outcomeNode, 30 | adjustNode = input$adjustNode 31 | ) 32 | }) 33 | 34 | onBookmarked(function(url) { 35 | message("bookmark: ", url) 36 | showBookmarkUrlModal(url) 37 | updateQueryString(url) 38 | }) 39 | 40 | onRestore(function(state) { 41 | showModal(modalDialog( 42 | title = NULL, 43 | easyClose = FALSE, 44 | footer = NULL, 45 | tags$p(class = "text-center", "Loading your shinyDag workspace, please wait."), 46 | tags$div(class = "gerkelab-spinner") 47 | )) 48 | 49 | # clear selected node and text input to try to prevent existing values from 50 | # changing the name of the node that gets selected on restore 51 | rvn$nodes <- node_unset_attribute(rvn$nodes, names(rvn$nodes), "parent") 52 | updateTextInput(session, "node_list_node_name", value = "") 53 | 54 | if (isTRUE(getOption("shinydag.debug", FALSE))) { 55 | names(state$values) %>% 56 | purrr::set_names() %>% 57 | purrr::map(~ state$values[[.]]) %>% 58 | purrr::compact() %>% 59 | purrr::iwalk(~ debug_input(.x, paste0("state$values$", .y))) 60 | } 61 | rvn$nodes <- state$values$rvn$nodes 62 | rve$edges <- state$values$rve$edges 63 | }) 64 | 65 | onRestored(function(state) { 66 | removeModal() 67 | updateSelectInput(session, "exposureNode", selected = state$values$sel$exposureNode) 68 | updateSelectInput(session, "outcomeNode", selected = state$values$sel$outcomeNode) 69 | updateSelectizeInput(session, "adjustNode", selected = state$values$sel$adjustNode) 70 | }) 71 | 72 | # ---- Global - Reactive Values ---- 73 | rve <- reactiveValues(edges = list()) 74 | rvn <- reactiveValues(nodes = list()) 75 | 76 | # rve$edges is a named list, e.g. for hash(A) -> hash(B): 77 | # rve$edges[edge_key(hash(A), hash(B))] = list(from = hash(A), to = hash(B)) 78 | 79 | # rvn$nodes is a named list where name is a hash 80 | # rvn$nodes$abcdefg = list(name, x, y) 81 | 82 | # ---- Sketch - Reactive Values Undo/Redo ---- 83 | rv_undo_state <- shinyThings::undoHistory( 84 | id = "undo_rv", 85 | value = reactive({ 86 | req(length(rvn$nodes) > 0) 87 | 88 | node_params <- c("name", "x", "y", "parent", "exposure", "outcome", "adjusted") 89 | nodes <- rvn$nodes %>% 90 | purrr::map(`[`, node_params) %>% 91 | purrr::map(purrr::compact) 92 | 93 | edge_params <- c("from", "to") 94 | edges <- rve$edges %>% 95 | purrr::map(`[`, edge_params) %>% 96 | purrr::map(purrr::compact) 97 | 98 | list( 99 | nodes = nodes, 100 | edges = edges 101 | ) 102 | }) 103 | ) 104 | 105 | observe({ 106 | req(!is.null(rv_undo_state())) 107 | 108 | rv_state <- rv_undo_state() 109 | debug_input(rv_state$nodes, "undo/redo - new nodes") 110 | debug_input(rv_state$edges, "undo/redo - new edges") 111 | rvn$nodes <- rv_state$nodes 112 | rve$edges <- rv_state$edges 113 | }, priority = 1000) 114 | 115 | # ---- Sketch - Node Controls ---- 116 | node_btn_id <- function(node_hash) paste0("node_toggle_", node_hash) 117 | node_btn_get_hash <- function(node_btn_id) sub("node_toggle_", "", node_btn_id, fixed = TRUE) 118 | 119 | node_list_buttons_redraw <- reactiveVal(Sys.time()) 120 | node_list_node_is_new <- reactiveVal(FALSE) 121 | node_list_selected_child <- reactive({ node_child(rvn$nodes) }) # TODO: remove 122 | node_list_selected_node <- reactiveVal(NULL) 123 | observe({ 124 | I("update selected node?") 125 | # this feels hacky but on the one hand we want to be able to update the 126 | # selected parent node just by updating rvn$nodes, and on the other we don't 127 | # want to propagate a reactive change if the value stays the same. So this 128 | # observer is kind of like a debouncer for node_list_selected_node() 129 | current_selected_node <- isolate(node_list_selected_node()) 130 | new_selected_node <- node_parent(rvn$nodes) 131 | if (!identical(current_selected_node, new_selected_node)) { 132 | node_list_selected_node(new_selected_node) 133 | } 134 | }) 135 | 136 | # debug selected nodes 137 | observe({ 138 | debug_input(node_list_selected_node(), "node_list_selected_node") 139 | debug_input(node_list_selected_child(), "node_list_selected_child") 140 | }) 141 | 142 | # Handle add node button, creates new node and sets focus 143 | observeEvent(input$node_list_node_add, { 144 | new_node_hash <- digest::digest(Sys.time()) 145 | rvn$nodes <- node_new(rvn$nodes, new_node_hash, "new node") %>% 146 | node_set_attribute(new_node_hash, "parent") 147 | node_list_buttons_redraw(Sys.time()) 148 | node_list_node_is_new(TRUE) 149 | }) 150 | 151 | # Show, hide or update node name text input 152 | observe({ 153 | I("show/hide/update node name text box") 154 | if (is.null(node_list_selected_node())) { 155 | shinyjs::hide("node_list_node_name_container") 156 | return() 157 | } 158 | 159 | s_node_selected <- node_list_selected_node() 160 | 161 | # Selected node already exists, update UI 162 | shinyjs::show("node_list_node_name_container") 163 | shinyjs::runjs("set_input_focus('node_list_node_name')") 164 | s_node_name <- node_name_from_hash(isolate(rvn$nodes), s_node_selected) 165 | if (isolate(node_list_node_is_new())) { 166 | node_list_node_is_new(FALSE) 167 | updateTextInput(session, "node_list_node_name", value = "", placeholder = "Enter Node Name") 168 | } else { 169 | updateTextInput( 170 | session, 171 | "node_list_node_name", 172 | value = unname(s_node_name) 173 | ) 174 | } 175 | }, priority = 1000) 176 | 177 | # Handle node name text input 178 | node_name_text_input <- reactive({ 179 | input$node_list_node_name 180 | }) 181 | 182 | observe({ 183 | I("update node name") 184 | node_name_debounced <- debounce(node_name_text_input, 750) 185 | node_name <- node_name_debounced() 186 | debug_input(node_name, "node_list_node_name (debounced)") 187 | s_node <- isolate(node_list_selected_node()) 188 | req(s_node, node_name != "") 189 | rvn$nodes <- node_update(isolate(rvn$nodes), s_node, node_name) 190 | }, priority = 2000) 191 | 192 | # Show editing buttons when appropriate 193 | observe({ 194 | I("toggle edit buttons") 195 | if (is.null(node_list_selected_node()) || !length(rvn$nodes)) { 196 | # no node selected, can only add a new node 197 | shinyjs::hide("node_list_node_delete") 198 | } else { 199 | # can now delete any selected node 200 | shinyjs::show("node_list_node_delete") 201 | } 202 | }) 203 | 204 | # Action: delete node 205 | observeEvent(input$node_list_node_delete, { 206 | # Remove node 207 | node_to_delete <- node_list_selected_node() 208 | rvn$nodes[[node_to_delete]] <- NULL 209 | 210 | # Remove any edges 211 | edges_with_node <- rve$edges %>% 212 | purrr::keep(~ node_to_delete %in% c(.$from, .$to)) %>% 213 | names() 214 | 215 | if (length(edges_with_node)) rve$edges[edges_with_node] <- NULL 216 | 217 | updateRadioSwitchButtons("clickpad_click_action", selected = "parent") 218 | shinyjs::hide("node_list_node_name_container") 219 | shinyjs::hide("node_list_node_delete") 220 | }) 221 | 222 | # ---- Sketch - Help Text ---- 223 | output$node_list_helptext <- renderUI({ 224 | s_node <- node_list_selected_node() 225 | no_nodes <- length(rvn$nodes) == 0 226 | not_enough_nodes <- length(rvn$nodes) < 2 227 | no_node_selected <- !no_nodes && is.null(s_node) 228 | no_dag_nodes <- !no_nodes && length(nodes_in_dag(rvn$nodes)) == 0 229 | not_enough_dag_nodes <- !no_dag_nodes && length(nodes_in_dag(rvn$nodes)) < 2 230 | node_in_dag <- !no_dag_nodes && s_node %in% nodes_in_dag(rvn$nodes) 231 | 232 | if (no_nodes) { 233 | helpText( 234 | "Use the", icon("plus"), "button above to add a node", 235 | "to your shinyDAG workspace" 236 | ) 237 | } else if (not_enough_nodes) { 238 | helpText("Add another node to your shinyDAG workspace") 239 | } else if (no_dag_nodes) { 240 | helpText("Drag a node from the staging area into the DAG or click its label to edit") 241 | } else if (not_enough_dag_nodes) { 242 | helpText("Drag another node from the staging area into the DAG") 243 | } else if (input$clickpad_click_action == "parent") { 244 | helpText("Click on a node label to activate as causal node or to edit its label") 245 | } else if (input$clickpad_click_action == "child") { 246 | helpText( 247 | "Click on a node label to draw or remove a causal arrow from", 248 | tags$strong(node_name_from_hash(rvn$nodes, node_list_selected_node())), 249 | "or click", 250 | tags$strong(node_name_from_hash(rvn$nodes, node_list_selected_node())), 251 | "again to deselect" 252 | ) 253 | } 254 | }) 255 | 256 | # ---- Sketch - Edge Help Text ---- 257 | req_nodes <- function() { 258 | if (!length(rvn$nodes)) { 259 | cat("\n No Nodes!") 260 | edge_helptext("Please add a node to the DAG first.") 261 | FALSE 262 | } else TRUE 263 | } 264 | 265 | edge_helptext <- function(inner, tag = "div", class = "help-block text-danger alert-edge") { 266 | edge_helptext_trigger(Sys.time()) 267 | edge_helptext_feedback(list(class = class, inner = inner, tag = tag)) 268 | } 269 | 270 | edge_normal_help_html <- list( 271 | inner = "Double-click on a node to set parent node. Single-click to set child node.", 272 | class = "help-block", 273 | tag = "p" 274 | ) 275 | edge_helptext_trigger <- reactiveVal(Sys.time()) 276 | edge_helptext_feedback <- reactiveVal(NULL) 277 | 278 | output$edge_list_helptext <- renderUI({ 279 | debug_input(isolate(edge_helptext_feedback()), "edge_helptext_feedback") 280 | 281 | edge_helptext_trigger() 282 | 283 | if (!is.null(isolate(edge_helptext_feedback()))) { 284 | invalidateLater(4800) 285 | } 286 | 287 | html <- isolate(edge_helptext_feedback()) %||% edge_normal_help_html 288 | edge_helptext_feedback(NULL) 289 | tag(html$tag, list(class = html$class, html$inner)) 290 | }) 291 | 292 | # ---- Sketch - Clickpad ---- 293 | plotly_source_id <- paste0("clickpad_", session$token) 294 | clickpad_new_locations <- callModule( 295 | clickpad, "clickpad", 296 | nodes = reactive(rvn$nodes), 297 | edges = reactive(rve$edges), 298 | plotly_source = plotly_source_id 299 | ) 300 | 301 | observe({ 302 | new <- clickpad_new_locations() 303 | 304 | req(new) 305 | debug_input(new, "clickpad_new_locations()") 306 | 307 | rvn$nodes <- node_update(isolate(rvn$nodes), new$hash, x = unname(new$x), y = unname(new$y)) 308 | }) 309 | 310 | # ---- Sketch - Clickpad - Click Events ---- 311 | observe({ 312 | I("clickpad click event handler") 313 | clicked_annotation <- event_data( 314 | "plotly_clickannotation", source = plotly_source_id, priority = "event" 315 | ) 316 | req(clicked_annotation[["_input"]]$node_hash) 317 | 318 | click_action = isolate(input$clickpad_click_action) 319 | clicked_hash = clicked_annotation[["_input"]]$node_hash 320 | 321 | nodes <- isolate(rvn$nodes) 322 | 323 | s_node_parent <- node_parent(nodes) 324 | s_node_child <- node_child(nodes) 325 | 326 | if (click_action == "parent") { 327 | # toggle clicked node as parent node 328 | update_button <- nodes[[clicked_hash]]$x >= 0 && 329 | nodes %>% purrr::map_dbl("x") %>% { sum(. >= 0) > 1 } 330 | 331 | if (is.null(s_node_parent)) { 332 | nodes <- node_set_attribute(nodes, clicked_hash, "parent") 333 | } else if (clicked_hash == s_node_parent) { 334 | update_button <- FALSE 335 | nodes <- node_unset_attribute(nodes, clicked_hash, c("parent", "child")) 336 | } else { 337 | nodes <- node_set_attribute(nodes, clicked_hash, "parent") 338 | nodes <- node_unset_attribute(nodes, clicked_hash, "child") 339 | } 340 | if (update_button) updateRadioSwitchButtons("clickpad_click_action", "child") 341 | 342 | } else if (click_action == "child") { 343 | # toggle clicked node as child node 344 | has_edge <- edge_exists(isolate(rve$edges), s_node_parent, s_node_child %||% clicked_hash) 345 | has_reverse_edge <- edge_exists(isolate(rve$edges), s_node_child %||% clicked_hash, s_node_parent) 346 | 347 | if (!is.null(s_node_parent) && s_node_parent == clicked_hash) { 348 | # Can't add edges to self 349 | rvn$nodes <- node_unset_attribute(nodes, names(nodes), c("parent", "child")) 350 | updateRadioSwitchButtons("clickpad_click_action", "parent") 351 | return() 352 | } else if (has_edge) { 353 | # Clicked on child node that already has edge, will be removing edge 354 | nodes <- node_unset_attribute(nodes, clicked_hash, "child") 355 | } else if (nodes[[clicked_hash]]$x < 0) { 356 | showNotification( 357 | "Edges can only be drawn between nodes that are in the DAG area.", 358 | duration = 5, 359 | type = "error" 360 | ) 361 | return() 362 | } else { 363 | nodes <- node_set_attribute(nodes, clicked_hash, "child") 364 | } 365 | 366 | # Remove reverse edge if it exists 367 | rv_edges <- isolate(rve$edges) 368 | if (has_reverse_edge) { 369 | rv_edges <- edge_toggle(rv_edges, clicked_hash, s_node_parent) 370 | } 371 | rve$edges <- edge_toggle(rv_edges, s_node_parent, clicked_hash) 372 | } 373 | rvn$nodes <- nodes 374 | }) 375 | 376 | # ---- Sketch - Clickpad - Click Type Buttons ---- 377 | observe({ 378 | I("clickpad click action reset to select?") 379 | reset_clickpad_action <- function() { 380 | updateRadioSwitchButtons("clickpad_click_action", "parent") 381 | invisible() 382 | } 383 | 384 | if (length(rvn$nodes) < 2) return(reset_clickpad_action()) 385 | 386 | dag_has_two_nodes <- rvn$nodes %>% purrr::map_dbl("x") %>% { sum(. >= 0) > 1 } 387 | if (!dag_has_two_nodes) return(reset_clickpad_action()) 388 | 389 | if (!is.null(node_list_selected_node())) { 390 | if (rvn$nodes[[node_list_selected_node()]]$x < 0) { 391 | reset_clickpad_action() 392 | } 393 | } 394 | }) 395 | 396 | # Don't allow clickpad edge adding unless node conditions are met 397 | observeEvent(input$clickpad_click_action, { 398 | req(input$clickpad_click_action == "child") 399 | valid <- FALSE 400 | if (length(rvn$nodes) < 2) { 401 | showNotification("Please add at least 2 nodes to your DAG workspace first.", duration = 5) 402 | } else if (rvn$nodes %>% purrr::keep(~ .$x >= 0) %>% length() < 2) { 403 | showNotification("Please drag at least 2 nodes into the DAG area first.", duration = 5) 404 | } else if (is.null(node_list_selected_node())) { 405 | showNotification("A parent node must be selected first", duration = 5) 406 | } else if (!length(nodes_in_dag(rvn$nodes))) { 407 | showNotification( 408 | "Please add a node to the DAG by dragging it out of the staging area.", 409 | duration = 5 410 | ) 411 | } else { 412 | valid <- TRUE 413 | } 414 | if (!valid) updateRadioSwitchButtons("clickpad_click_action", "parent") 415 | }) 416 | 417 | # ---- Sketch - Node Options ---- 418 | update_node_options <- function( 419 | nodes, 420 | inputId, 421 | updateFn, 422 | none_choice = TRUE, 423 | ... 424 | ) { 425 | available_choices <- c("None" = "", node_names(nodes)) 426 | if (!none_choice) available_choices <- available_choices[-1] 427 | s_choice <- intersect(isolate(input[[inputId]]), available_choices) 428 | # If inputId doesn't overlap with choices, lookup state in rvn$nodes 429 | if (!length(s_choice) || s_choice == "") { 430 | s_choice <- switch( 431 | inputId, 432 | "adjustNode" = node_adjusted(nodes), 433 | "exposureNode" = node_exposure(nodes), 434 | "outcomeNode" = node_outcome(nodes), 435 | character(0) 436 | ) 437 | } 438 | s_choice <- intersect(s_choice, available_choices) 439 | if (inputId == "adjustNode") debug_input(nodes, "nodes for E/O/A") 440 | debug_input(s_choice, inputId) 441 | # Fall back to the none choice 442 | if (!length(s_choice) && none_choice) { 443 | s_choice <- "" 444 | } 445 | 446 | updateFn( 447 | session, 448 | inputId, 449 | choices = available_choices, 450 | selected = s_choice, 451 | ... 452 | ) 453 | } 454 | 455 | observe({ 456 | update_node_options( 457 | rvn$nodes %>% purrr::keep(~ .$x >= 0), 458 | "adjustNode", 459 | updateSelectizeInput 460 | ) 461 | update_node_options( 462 | rvn$nodes %>% purrr::keep(~ .$x >= 0), 463 | "exposureNode", 464 | updateSelectInput 465 | ) 466 | update_node_options( 467 | rvn$nodes %>% purrr::keep(~ .$x >= 0), 468 | "outcomeNode", 469 | updateSelectInput 470 | ) 471 | }) 472 | 473 | observeEvent(input$exposureNode, { 474 | nodes <- isolate(rvn$nodes) 475 | if (input$exposureNode == "") { 476 | rvn$nodes <- node_unset_attribute(nodes, names(nodes), "exposure") 477 | } else if (input$exposureNode == input$outcomeNode) { 478 | updateSelectInput(session, "outcomeNode", selected = "") 479 | rvn$nodes <- node_unset_attribute(nodes, names(nodes), "outcome") 480 | } else { 481 | rvn$nodes <- node_set_attribute(nodes, input$exposureNode, "exposure") 482 | } 483 | }) 484 | 485 | observeEvent(input$outcomeNode, { 486 | nodes <- isolate(rvn$nodes) 487 | if (input$outcomeNode == "") { 488 | rvn$nodes <- node_unset_attribute(nodes, names(nodes), "outcome") 489 | } else if (input$outcomeNode == input$exposureNode) { 490 | updateSelectInput(session, "exposureNode", selected = "") 491 | rvn$nodes <- node_unset_attribute(nodes, names(nodes), "exposure") 492 | } else { 493 | rvn$nodes <- node_set_attribute(nodes, input$outcomeNode, "outcome") 494 | } 495 | }) 496 | 497 | observe({ 498 | nodes <- isolate(rvn$nodes) 499 | debug_input(input$adjustNode, "input$adjustNode") 500 | s_adjust <- input$adjustNode %||% "" 501 | rvn$nodes <- if (length(s_adjust) == 1 && s_adjust == "") { 502 | node_unset_attribute(nodes, names(nodes), "adjusted") 503 | } else { 504 | node_set_attribute(nodes, s_adjust, "adjusted") 505 | } 506 | }) 507 | 508 | output$adjustText <- renderText({ 509 | if (is.null(input$exposureNode) & is.null(input$outcomeNode)) { 510 | paste0("Minimal sufficient adjustment sets") 511 | } else { 512 | paste0( 513 | "Minimal sufficient adjustment set(s) to estimate the effect of ", 514 | input$exposureNode, 515 | " on ", 516 | input$outcomeNode 517 | ) 518 | } 519 | }) 520 | 521 | # ---- DAG - Functions ---- 522 | make_dagitty <- function(nodes, edges, exposure = NULL, outcome = NULL, adjusted = NULL) { 523 | dagitty_edges <- edge_frame(edges, nodes) %>% 524 | glue::glue_data('"{from_name}" -> "{to_name}"') %>% 525 | paste(collapse = "; ") 526 | 527 | dagitty_code <- glue::glue("dag {{ {dagitty_edges} }}") 528 | debug_input(dagitty_code, "dagitty_code") 529 | 530 | gdag <- dagitty(dagitty_code) 531 | 532 | if (isTruthy(exposure)) exposures(gdag) <- node_name_from_hash(nodes, exposure) 533 | if (isTruthy(outcome)) outcomes(gdag) <- node_name_from_hash(nodes, outcome) 534 | if (isTruthy(adjusted)) adjustedNodes(gdag) <- node_name_from_hash(nodes, adjusted) 535 | 536 | gdag 537 | } 538 | 539 | dagitty_open_paths <- function(nodes, edges, exposure, outcome, adjusted) { 540 | node_names <- invertNames(node_names(nodes)) 541 | gd <- make_dagitty( 542 | edges = edges, nodes = nodes, 543 | exposure = exposure, outcome = outcome, adjusted = adjusted 544 | ) 545 | 546 | exp_outcome_paths <- paths( 547 | gd, 548 | Z = adjusted %??% unname(node_names[adjusted]) 549 | ) 550 | 551 | exp_outcome_paths$paths[as.logical(exp_outcome_paths$open)] 552 | } 553 | 554 | dagitty_open_paths_causal <- function(nodes, edges, exposure, outcome, adjusted) { 555 | node_names <- invertNames(node_names(nodes)) 556 | gd <- make_dagitty( 557 | edges = edges, nodes = nodes, 558 | exposure = exposure, outcome = outcome, adjusted = adjusted 559 | ) 560 | 561 | exp_outcome_paths <- paths( 562 | gd, 563 | Z = adjusted %??% unname(node_names[adjusted]), 564 | directed=TRUE 565 | ) 566 | 567 | exp_outcome_paths$paths[as.logical(exp_outcome_paths$open)] 568 | } 569 | 570 | dagitty_sets <- function(nodes, edges, exposure, outcome, adjusted) { 571 | node_names <- invertNames(node_names(nodes)) 572 | gd <- make_dagitty( 573 | edges = edges, nodes = nodes, 574 | exposure = exposure, outcome = outcome, adjusted = adjusted 575 | ) 576 | 577 | minimal_sets <- adjustmentSets( 578 | gd, 579 | exposure = exposure %??% unname(node_names[exposure]), 580 | outcome = outcome %??% unname(node_names[outcome]), 581 | ) 582 | 583 | } 584 | 585 | dagitty_format_paths <- function(paths) { 586 | tagList( 587 | lapply(trimws(paths), function(x) tags$p(tags$code(x))) 588 | ) 589 | } 590 | 591 | # ---- Sketch - DAG - Open Exp/Outcome Paths ---- 592 | dagitty_has_required_nodes <- reactive({ 593 | req( 594 | length(nodes_in_dag(rvn$nodes)), 595 | length(edges_in_dag(rve$edges, rvn$nodes)) 596 | ) 597 | 598 | # need both exposure and outcome node 599 | requires_nodes <- c("Exposure" = input$exposureNode, "Outcome" = input$outcomeNode) 600 | missing_nodes <- names(requires_nodes[grepl("^$", requires_nodes)]) 601 | validate( 602 | need( 603 | length(missing_nodes) == 0, 604 | glue::glue("Please choose {str_and(missing_nodes)} {str_plural(missing_nodes, 'node')}") 605 | ) 606 | ) 607 | 608 | TRUE 609 | }) 610 | 611 | dagitty_open_exp_outcome_paths <- reactive({ 612 | dagitty_has_required_nodes() 613 | 614 | purrr::safely(dagitty_open_paths)( 615 | nodes = rvn$nodes, edges = rve$edges, exposure = input$exposureNode, 616 | outcome = input$outcomeNode, adjusted = input$adjustNode 617 | ) 618 | }) 619 | 620 | dagitty_open_exp_outcome_paths_causal <- reactive({ 621 | dagitty_has_required_nodes() 622 | 623 | purrr::safely(dagitty_open_paths_causal)( 624 | nodes = rvn$nodes, edges = rve$edges, exposure = input$exposureNode, 625 | outcome = input$outcomeNode, adjusted = input$adjustNode 626 | ) 627 | }) 628 | 629 | dagitty_minimal_adjustment_sets <- reactive({ 630 | dagitty_has_required_nodes() 631 | 632 | purrr::safely(dagitty_sets)( 633 | nodes = rvn$nodes, edges = rve$edges, exposure = input$exposureNode, 634 | outcome = input$outcomeNode, adjusted = input$adjustNode 635 | ) 636 | }) 637 | 638 | dag_diagnostic_result <- function(label, ...) { 639 | fluidRow( 640 | class = "dag-diagnostic__result", 641 | tags$div( 642 | class = "col-sm-6 col-lg-4 dag-diagnostic__label", 643 | tags$p(tags$strong(label)) 644 | ), 645 | tags$div( 646 | class = "col-sm-6 col-lg-8 dag-diagnostic__value", 647 | ... 648 | ) 649 | ) 650 | } 651 | 652 | output$dagExposureOutcomeDiagnositcs <- renderUI({ 653 | validate(need(length(edges_in_dag(rve$edges, rvn$nodes)) > 0, "")) 654 | 655 | if ((input$debug_trigger %||% 0) > 0) browser() 656 | dagitty_has_required_nodes() 657 | 658 | open_paths <- dagitty_open_exp_outcome_paths() 659 | open_paths_causal <- dagitty_open_exp_outcome_paths_causal() 660 | adj_sets <- dagitty_minimal_adjustment_sets() 661 | 662 | validate(need( 663 | is.null(open_paths$error) | is.null(open_paths_causal$error), 664 | paste( 665 | "There was an error building your graph. It may not be fully or", 666 | "correctly specified. If you have special characters in your node", 667 | "change the node name to something short and representative. You can", 668 | "set more detailed node labels in the \"Tweak\" panel." 669 | ) 670 | ), errorClass = " text-danger") 671 | 672 | open_paths_direct <- open_paths_causal$result 673 | open_paths_indirect <- setdiff(open_paths$result, open_paths_causal$result) 674 | adj_sets <- adj_sets$result 675 | cleaning_sets <- c() 676 | for(i in 1:length(adj_sets)){ 677 | cleaning_sets <- c(cleaning_sets,paste0("{",adj_sets[[i]][1],",", adj_sets[[i]][2],"}")) 678 | } 679 | 680 | tagList( 681 | h4("Exposure and Outcome Information"), 682 | dag_diagnostic_result( 683 | label = "Minimal Adjustment Set", 684 | if (cleaning_sets!="{NULL,NULL}") { 685 | paste(cleaning_sets, collapse=" ") 686 | } else helpText( 687 | "No minimal adjustment sets between exposure and outcome." 688 | ) 689 | ), 690 | dag_diagnostic_result( 691 | label = "Open Causal Associations", 692 | if (length(open_paths_direct)) { 693 | dagitty_format_paths(open_paths_direct) 694 | } else helpText( 695 | "No open causal associations between exposure and outcome." 696 | ) 697 | ), 698 | dag_diagnostic_result( 699 | label = "Open Non-Causal Associations", 700 | if (length(open_paths_indirect)) { 701 | dagitty_format_paths(open_paths_indirect) 702 | } else helpText( 703 | "No open non-causal associations between exposure and outcome." 704 | ) 705 | ) 706 | ) 707 | }) 708 | 709 | # ---- Tweak - Edge Aesthetics ---- 710 | 711 | # Create the edge aesthetics control UI, only updated when tab is activated 712 | output$edge_aes_ui <- renderUI({ 713 | req(input$shinydag_page == "tweak") 714 | req(length(isolate(rve$edges)) > 0) 715 | rv_edge_frame <- edge_frame(isolate(rve$edges), isolate(rvn$nodes)) %>% 716 | arrange(from_name, to_name) 717 | 718 | tagList( 719 | purrr:::pmap(rv_edge_frame, ui_edge_controls_row, input = input) 720 | ) 721 | }) 722 | 723 | # Watch edge UI inputs and update rve$edges when inputs change 724 | observe({ 725 | I("update edge aesthetics") 726 | req(length(rve$edges) > 0, grepl("^angle__", names(input))) 727 | rv_edges <- isolate(rve$edges) 728 | 729 | edge_ui <- get_hashed_input_with_prefix( 730 | input, 731 | prefix = "angle|color|lty|lineT", 732 | hash_sep = "__" 733 | ) 734 | 735 | for (edge in edge_ui) { 736 | if (!edge$hash %in% names(rv_edges)) next 737 | this_edge <- edge[setdiff(names(edge), "hash")] 738 | for (prop in names(this_edge)) { 739 | if (is.na(this_edge[[prop]])) next 740 | rv_edges[[edge$hash]][[prop]] <- this_edge[[prop]] 741 | } 742 | } 743 | debug_input(bind_rows(rv_edges, .id = "hash"), "rve$edges after aes update") 744 | rve$edges <- rv_edges 745 | }, priority = -50) 746 | 747 | # ---- Tweak - Node Aesthetics ---- 748 | 749 | # Create the node aesthetics control UI, only updated when tab is activated 750 | output$node_aes_ui <- renderUI({ 751 | req(input$shinydag_page == "tweak") 752 | req(length(isolate(rvn$nodes)) > 0) 753 | rv_node_frame <- node_frame(isolate(rvn$nodes)) 754 | 755 | tagList( 756 | purrr:::pmap(rv_node_frame, ui_node_controls_row, input = input) 757 | ) 758 | }) 759 | 760 | # Watch edge UI inputs and update rve$edges when inputs change 761 | observe({ 762 | I("update node aesthetics") 763 | req(length(rvn$nodes) > 0, grepl("^color_fill_", names(input))) 764 | rv_nodes <- isolate(rvn$nodes) 765 | 766 | node_ui <- get_hashed_input_with_prefix( 767 | input, 768 | prefix = "name_latex|(color_(draw|fill|text))", 769 | hash_sep = "__" 770 | ) 771 | 772 | for (node in node_ui) { 773 | if (!node$hash %in% names(rv_nodes)) next 774 | this_node <- node[setdiff(names(node), "hash")] 775 | for (prop in names(this_node)) { 776 | if (is.na(this_node[[prop]])) next 777 | rv_nodes[[node$hash]][[prop]] <- this_node[[prop]] 778 | } 779 | } 780 | debug_input(bind_rows(rv_nodes, .id = "hash"), "rvn$nodes after aes update") 781 | rvn$nodes <- rv_nodes 782 | }, priority = -50) 783 | 784 | 785 | # ---- Global - TikZ Code ---- 786 | edge_points_rv <- reactive({ 787 | req(length(rve$edges) > 0) 788 | ep <- edge_points(rve$edges, rvn$nodes) 789 | req(nrow(ep) > 0) 790 | ep 791 | }) 792 | 793 | dag_node_lines <- function(nodeFrame) { 794 | dag_bounds <- 795 | nodeFrame %>% 796 | filter(!is.na(name)) %>% 797 | summarize_at(vars(x, y), list(min = min, max = max)) 798 | 799 | nodeFrame <- nodeFrame %>% 800 | filter( 801 | between(x, dag_bounds$x_min, dag_bounds$x_max) && 802 | between(y, dag_bounds$y_min, dag_bounds$y_max) 803 | ) 804 | 805 | nodeFrame[is.na(nodeFrame$tikz_node), "tikz_node"] <- "~" 806 | 807 | nodeLines <- vector("character", 0) 808 | for (i in unique(nodeFrame$y)) { 809 | createLines <- paste0( 810 | paste(nodeFrame[nodeFrame$y == i, ]$tikz_node, collapse = " & "), 811 | " \\\\\n" 812 | ) 813 | nodeLines <- c(nodeLines, createLines) 814 | } 815 | nodeLines <- rev(nodeLines) 816 | 817 | paste0( 818 | "\\matrix(m)[matrix of nodes, row sep=2.6em, column sep=2.8em,", 819 | "text height=1.5ex, text depth=0.25ex]\n", 820 | "{\n ", paste(nodeLines, collapse = " "), "};" 821 | ) 822 | } 823 | 824 | tikz_node_points <- reactive({ 825 | req(input$shinydag_page %in% c("tweak", "latex")) 826 | req(length(rvn$nodes)) 827 | update_tikz_because_global_opts() 828 | node_df <- node_frame(rvn$nodes) 829 | req(nrow(node_df) > 0) 830 | node_frame_add_style(node_df) 831 | }) 832 | 833 | tikz_code_from_app <- reactive({ 834 | d_tikz_node_points <- debounce(tikz_node_points, 1000) 835 | nodePts <- d_tikz_node_points() 836 | req(nrow(nodePts) > 0) 837 | 838 | has_style <- any(!is.na(nodePts$tikz_style)) 839 | tikz_style_defs <- nodePts$tikz_style[!is.na(nodePts$tikz_style)] 840 | 841 | styleZ <- paste( 842 | "\\tikzset{", 843 | paste0(" every node/.style={ }", if (has_style) "," else "\n}"), 844 | if (has_style) paste(" ", tikz_style_defs, collapse = ",\n"), 845 | if (has_style) "}", 846 | sep = "\n" 847 | ) 848 | startZ <- "\\begin{tikzpicture}[>=latex]" 849 | endZ <- "\\end{tikzpicture}" 850 | pathZ <- "\\path[->,font=\\scriptsize,>=angle 90]" 851 | 852 | d_x <- min(nodePts$x) - 1L 853 | d_y <- min(nodePts$y) - 1L 854 | 855 | nodePts$x <- nodePts$x - d_x 856 | nodePts$y <- nodePts$y - d_y 857 | 858 | y_max <- max(nodePts$y) 859 | 860 | nodeLines <- nodePts %>% 861 | tidyr::complete( 862 | x = seq(min(nodePts$x), max(nodePts$x)), 863 | y = seq(min(nodePts$y), max(nodePts$y)) 864 | ) %>% 865 | dag_node_lines() 866 | 867 | edgeLines <- character() 868 | 869 | if (length(edges_in_dag(rve$edges, isolate(rvn$nodes)))) { 870 | # edge_points_rv() is a reactive that gathers values from aesthetics UI 871 | # but it can be noisy, so we're debouncing to delay TeX rendering until values are constant 872 | edgePts <- debounce(edge_points_rv, 5000)() 873 | 874 | tikz_point <- function(x, y, d_x, d_y, y_max) { 875 | glue::glue("(m-{y_max - (y - d_y) + 1}-{x - d_x})") 876 | } 877 | 878 | edgePts <- edgePts %>% 879 | mutate( 880 | parent = tikz_point(from.x, from.y, d_x, d_y, y_max), 881 | child = tikz_point(to.x, to.y, d_x, d_y, y_max), 882 | edgeLine = glue::glue( 883 | "{parent} edge [>={input$arrowShape}, bend left = {edgePts$angle}, ", 884 | "color = {edgePts$color},{edgePts$lineT},{edgePts$lty}] node[auto] {{$~$}} {child}" 885 | ) 886 | ) 887 | 888 | debug_input(select(edgePts, hash, matches("^(from|to)_name"), parent, child, edgeLine), "edgeLines") 889 | edgeLines <- edgePts$edgeLine 890 | } 891 | 892 | edgeLines <- paste0(pathZ, paste(edgeLines, collapse = ""), ";") 893 | 894 | paste(c(styleZ, startZ, nodeLines, edgeLines, endZ), collapse = "\n") 895 | }) 896 | 897 | make_graph <- function(nodes, edges) { 898 | g <- make_empty_graph() 899 | if (nrow(node_frame(nodes))) { 900 | g <- g + node_vertices(nodes) 901 | } 902 | if (length(edges)) { 903 | # Add edges 904 | g <- g + edge_edges(edges, nodes) 905 | } 906 | g 907 | } 908 | 909 | # ---- Tweak - Global Options ---- 910 | update_tikz_because_global_opts <- reactiveVal(FALSE) 911 | 912 | observe({ 913 | I("update tex_opts") 914 | `%|%` <- function(x, y) { 915 | x <- x %||% y 916 | if (is.na(x)) y else x 917 | } 918 | tex_opts$set(list( 919 | density = 1200, 920 | margin = list( 921 | left = input$tex_opts_margin_left %|% 0, 922 | top = input$tex_opts_margin_bottom %|% 0, # bug? 923 | right = input$tex_opts_margin_right %|% 0, 924 | bottom = input$tex_opts_margin_top %|% 0 925 | ), 926 | cleanup = c("aux", "log") 927 | )) 928 | update_tikz_because_global_opts(!isolate(update_tikz_because_global_opts())) 929 | }) 930 | 931 | # ---- Tweak - dagitty DAG ---- 932 | dag_dagitty <- reactive({ 933 | req( 934 | tweak_preview_visible(), 935 | length(nodes_in_dag(rvn$nodes)), 936 | length(edges_in_dag(rve$edges)), 937 | input$exposureNode, input$outcomeNode, input$adjustNode 938 | ) 939 | make_dagitty(rvn$nodes, rve$edges, input$exposureNode, input$outcomeNode, input$adjustNode) 940 | }) 941 | 942 | dag_tidy <- reactive({ 943 | req( 944 | tweak_preview_visible(), 945 | length(nodes_in_dag(rvn$nodes)), 946 | length(edges_in_dag(rve$edges)), 947 | input$exposureNode, input$outcomeNode, input$adjustNode 948 | ) 949 | make_dagitty(rvn$nodes, rve$edges, input$exposureNode, input$outcomeNode, input$adjustNode) %>% 950 | tidy_dagitty() 951 | }) 952 | 953 | # ---- Tweak - Preview ---- 954 | tweak_preview_visible <- callModule( 955 | module = dagPreview, 956 | id = "tweak_preview", 957 | session_dir = SESSION_TEMPDIR, 958 | tikz_code = reactive({ 959 | req(input$shinydag_page == "tweak") 960 | tikz_code_from_app() 961 | }), 962 | dag_dagitty, 963 | dag_tidy, 964 | has_edges = reactive(nrow(edge_frame(rve$edges, rvn$nodes))) 965 | ) 966 | 967 | # ---- LaTeX - Editor ---- 968 | output$texEdit <- renderUI({ 969 | tikz_lines <- tikz_code_from_app() 970 | 971 | if (is.null(tikz_lines)) { 972 | tikz_lines <- "\\\\begin{tikzpicture}[>=latex]\n\\\\end{tikzpicture}" 973 | } else { 974 | # double escape backslashes 975 | tikz_lines <- gsub("\\", "\\\\", tikz_lines, fixed = TRUE) 976 | } 977 | aceEditor( 978 | "manual_tikz", 979 | mode = "latex", 980 | value = paste(tikz_lines, collapse = "\n"), 981 | theme = "chrome", 982 | wordWrap = TRUE, 983 | highlightActiveLine = TRUE 984 | ) 985 | }) 986 | 987 | latex_preview_visible <- callModule( 988 | module = dagPreview, 989 | id = "latex_preview", 990 | session_dir = SESSION_TEMPDIR, 991 | reactive({ 992 | req(input$shinydag_page == "latex") 993 | input$manual_tikz 994 | }) 995 | ) 996 | 997 | # ---- About - Examples ---- 998 | example_value <- callModule(examples, "example") 999 | 1000 | observe({ 1001 | req(example_value()) 1002 | 1003 | ex_val <- example_value() 1004 | rvn$nodes <- ex_val$nodes 1005 | rve$edges <- ex_val$edges 1006 | 1007 | Sys.sleep(0.25) 1008 | 1009 | shinydashboard::updateTabItems(session, "shinydag_page", "sketch") 1010 | 1011 | }) 1012 | 1013 | } 1014 | -------------------------------------------------------------------------------- /shinydag.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /ui.R: -------------------------------------------------------------------------------- 1 | 2 | # Components -------------------------------------------------------------- 3 | 4 | components <- list(toolbar = list()) 5 | 6 | # Components - Clickpad ---- 7 | components$toolbar$clickpad_action <- tags$div( 8 | radioSwitchButtons( 9 | "clickpad_click_action", 10 | HTML(paste(icon("mouse-pointer"), "Click a node to...")), 11 | choices = c("Select" = "parent", "Draw/Remove Edge" = "child"), 12 | selected = "parent", 13 | selected_background = "#D3751C" 14 | ) 15 | ) 16 | 17 | # Components - Node List ---- 18 | components$toolbar$node_list_actions <- tags$div( 19 | class = "btn-toolbar", 20 | role = "toolbar", 21 | tags$form( 22 | class = "form-inline", 23 | tags$div( 24 | class = "form-group", 25 | tags$div( 26 | class = "btn-group", 27 | role = "group", 28 | actionButton( 29 | input = "node_list_node_add", 30 | label = "Add New Node", 31 | icon = icon("plus"), 32 | alt = "Add New Node to Workspace", 33 | `data-toggle` = "tooltip", 34 | `data-placement` = "bottom", 35 | title = "Add New Node to Workspace" 36 | ), 37 | shinyjs::hidden( 38 | actionButton( 39 | "node_list_node_delete", "Delete Node", icon("trash"), 40 | alt = "Delete Node", 41 | `data-toggle` = "tooltip", 42 | `data-placement` = "bottom", 43 | title = "Delete Node") 44 | ) 45 | ) 46 | ) 47 | ) 48 | ) 49 | 50 | components$toolbar$node_list_name <- tags$div( 51 | style = "padding-top: 15px; min-height: 90px;", 52 | shinyjs::hidden( 53 | tags$div( 54 | id = "node_list_node_name_container", 55 | class = "col-xs-12", 56 | textInput("node_list_node_name", "Node Name", width = "100%") 57 | ) 58 | ) 59 | ) 60 | 61 | # Components - About ---- 62 | components$about <- list() 63 | 64 | components$about$gerkelab <- tagList( 65 | h3("Development Team"), 66 | tags$ul( 67 | tags$li("Jordan Creed"), 68 | tags$li(tags$a(href = "https://www.garrickadebuie.com", "Garrick Aden-Buie")), 69 | tags$li(tags$a(href = "https://travisgerke.com", "Travis Gerke")) 70 | ), 71 | p( 72 | "For more information about our lab and other projects please check", 73 | "out our website at", 74 | tags$a(href = "http://gerkelab.com", "gerkelab.com") 75 | ), 76 | p( 77 | "All code and detailed instructions for usage is available on GitHub at", 78 | tags$a( 79 | href = "https://github.com/GerkeLab/shinyDAG", 80 | "GerkeLab/shinyDag" 81 | ) 82 | ), 83 | p( 84 | "If you have any questions or comments, we would love to hear them.", 85 | "You can email us at", 86 | tags$a(href = "mailto:travis.gerke@moffitt.org", "travis.gerke@moffitt.org"), 87 | "or", 88 | HTML(paste0( 89 | tags$a(href = "mailto:jordan.h.creed@moffitt.org", "jordan.h.creed@moffitt.org"), 90 | "." 91 | )), 92 | "Or feel free to", 93 | tags$a( 94 | href = "https://github.com/GerkeLab/shinyDAG/issues", 95 | "open an issue" 96 | ), 97 | "in our GitHub repository." 98 | ) 99 | ) 100 | 101 | # components$about$usage <- tagList( 102 | # tags$h3("Using shinyDAG"), 103 | # tags$p( 104 | # "For more details on using shinyDAG please check out our", 105 | # tags$a( 106 | # href = "https://github.com/GerkeLab/shinyDAG/blob/master/README.md", 107 | # "README." 108 | # )) 109 | # ) 110 | 111 | # Components - Build ---- 112 | components$build <- box( 113 | title = "Build", 114 | id = "build-box", 115 | width = 12, 116 | fluidRow( 117 | id = "shinydag-toolbar", 118 | tags$div( 119 | class = "col-xs-12 col-md-5 shinydag-toolbar-actions", 120 | tags$div( 121 | class = "col-xs-12 col-sm-6 col-md-12", 122 | id = "shinydag-toolbar-node-list-action", 123 | components$toolbar$node_list_action 124 | ), 125 | tags$div( 126 | class = "col-xs-12 col-sm-6 col-md-12", 127 | style = "padding: 10px", 128 | id = "shinydag-toolbar-clickpad-action", 129 | components$toolbar$clickpad_action 130 | ) 131 | ), 132 | tags$div( 133 | class = "col-xs-12 col-md-7", 134 | components$toolbar$node_list_name 135 | ) 136 | ), 137 | fluidRow( 138 | column( 139 | width = 12, 140 | tags$div( 141 | class = "pull-left", 142 | uiOutput("node_list_helptext") 143 | ), 144 | shinyThings::undoHistoryUI( 145 | id = "undo_rv", 146 | class = "pull-right", 147 | back_text = "Undo", 148 | fwd_text = "Redo" 149 | ) 150 | ) 151 | ), 152 | fluidRow( 153 | column( 154 | width = 12, 155 | clickpad_UI("clickpad", height = "600px", width = "100%") 156 | ) 157 | ), 158 | if (getOption("shinydag.debug", FALSE)) fluidRow( 159 | column(width = 12, shinyThings::undoHistoryUI_debug("undo_rv")) 160 | ), 161 | fluidRow( 162 | tags$div( 163 | class = class_3_col, 164 | selectInput("exposureNode", "Exposure", choices = c("None" = ""), width = "100%") 165 | ), 166 | tags$div( 167 | class = class_3_col, 168 | selectInput("outcomeNode", "Outcome", choices = c("None" = ""), width = "100%") 169 | ), 170 | tags$div( 171 | class = class_3_col, 172 | selectizeInput("adjustNode", "Adjust for...", choices = c("None" = ""), width = "100%", multiple = TRUE) 173 | ) 174 | ), 175 | fluidRow( 176 | tags$div( 177 | class = "col-sm-12 col-md-9 col-lg-6", 178 | uiOutput("dagExposureOutcomeDiagnositcs") 179 | ) 180 | ) 181 | ) 182 | 183 | # Components - LaTeX ---- 184 | components$latex <- tagList( 185 | tags$p( 186 | "Use this tab to manually edit the TikZ generated by shinyDAG." 187 | ), 188 | helpText( 189 | "Note that changes made to the TikZ code below will not affect", 190 | "the DAG settings in the app. Changes made to the DAG elsewhere", 191 | "in shinyDAG will overwrite any changes made to the manually", 192 | "edited TikZ code below." 193 | ), 194 | uiOutput("texEdit") 195 | ) 196 | 197 | # Components - Tweak ---- 198 | components$tweak <- tabBox( 199 | title = "Edit DAG", 200 | id = "tab_control", 201 | # ---- Tab: Edit Aesthetics 202 | tabPanel( 203 | "Edges", 204 | value = "edit_edge_aesthetics", 205 | selectInput( 206 | "arrowShape", 207 | "Select arrow head", 208 | choices = c( 209 | "stealth", 210 | "stealth'", 211 | "diamond", 212 | "triangle 90", 213 | "hooks", 214 | "triangle 45", 215 | "triangle 60", 216 | "hooks reversed", 217 | "*" 218 | ), 219 | selected = "stealth" 220 | ), 221 | uiOutput("edge_aes_ui") 222 | ), 223 | tabPanel( 224 | "Nodes", 225 | value = "edit_node_aesthetics", 226 | uiOutput("node_aes_ui") 227 | ), 228 | tabPanel( 229 | "Page", 230 | value = "edit_page_aesthetics", 231 | tags$h3("Margins"), 232 | fluidRow( 233 | col_4( 234 | numericInput("tex_opts_margin_top", "Top", value = 0L, min = 0L, max = 500L, step = 1L) 235 | ), 236 | col_4( 237 | numericInput("tex_opts_margin_right", "Right", value = 0L, min = 0L, max = 500L, step = 1L) 238 | ), 239 | col_4( 240 | numericInput("tex_opts_margin_bottom", "Bottom", value = 0L, min = 0L, max = 500L, step = 1L) 241 | ), 242 | col_4( 243 | numericInput("tex_opts_margin_left", "Left", value = 0L, min = 0L, max = 500L, step = 1L) 244 | ) 245 | ) 246 | ) 247 | ) 248 | 249 | # UI - shinyDAG ----------------------------------------------------------- 250 | 251 | function(request) { 252 | dashboardPage( 253 | title = "shinyDAG", 254 | skin = "black", 255 | dashboardHeader( 256 | title = "shinyDAG", 257 | tags$li( 258 | class = "dropdown", 259 | actionLink( 260 | inputId = "._bookmark_", 261 | label = "Bookmark", 262 | icon = icon("link", lib = "glyphicon"), 263 | title = "Bookmark shinyDAG's state and get a URL for sharing.", 264 | `data-toggle` = "tooltip", 265 | `data-placement` = "bottom" 266 | ) 267 | ), 268 | tags$li( 269 | class = "dropdown", 270 | tags$a( 271 | href = "https://github.com/gerkelab/shinyDAG/", 272 | title = "shinyDAG on GitHub", 273 | target = "_blank", 274 | icon("github") 275 | ) 276 | ), 277 | tags$li( 278 | class = "dropdown", 279 | tags$a( 280 | href = "https://gerkelab.com/project/shinyDAG/", 281 | title = "GerkeLab Project Page", 282 | target = "_blank", 283 | icon("flask") 284 | ) 285 | ) 286 | ), 287 | dashboardSidebar( 288 | sidebarMenu( 289 | id = "shinydag_page", 290 | menuItem("Sketch", tabName = "sketch", icon = icon("share-alt")), 291 | menuItem("Tweak", tabName = "tweak", icon = icon("sliders")), 292 | menuItem("LaTeX", tabName = "latex", icon = icon("file-text-o")), 293 | menuItem("About", tabName = "about", icon = icon("info")) 294 | ) 295 | ), 296 | dashboardBody( 297 | shinyjs::useShinyjs(), 298 | tags$script(src = "shinydag.js", async = TRUE), 299 | includeCSS("www/AdminLTE.gerkelab.min.css"), 300 | includeCSS("www/_all-skins.gerkelab.min.css"), 301 | includeCSS("www/shinydag.css"), 302 | chooseSliderSkin("Flat", "#418c7a"), 303 | tags$a( 304 | href = "https://gerkelab.com", 305 | target = "_blank", 306 | tags$div(class = "gerkelab-logo") 307 | ), 308 | if (isTRUE(getOption("shinydag.debug", FALSE))) tagList( 309 | div( 310 | class = 'btn-group debug-buttons', 311 | actionButton("debug_browse", "Browse"), 312 | actionButton("debug_trigger", label = "Trigger Debug") 313 | ) 314 | ), 315 | tabItems( 316 | tabItem( 317 | tabName = "sketch", 318 | components$build 319 | ), 320 | tabItem( 321 | tabName = "tweak", 322 | two_column_flips_on_mobile( 323 | components$tweak, 324 | box( 325 | title = "Preview DAG", 326 | dagPreviewUI("tweak_preview", include_graph_downloads = TRUE) 327 | ) 328 | ) 329 | ), 330 | tabItem( 331 | tabName = "latex", 332 | two_column_flips_on_mobile( 333 | box( 334 | title = "Edit LaTeX", 335 | components$latex 336 | ), 337 | box( 338 | title = "Preview LaTeX", 339 | dagPreviewUI("latex_preview", include_graph_downloads = FALSE) 340 | ) 341 | ) 342 | ), 343 | tabItem( 344 | tabName = "about", 345 | box( 346 | title = "Examples", 347 | width = "12 col-md-6", 348 | examples_UI("example") 349 | ), 350 | box( 351 | title = "About shinyDAG", 352 | width = "12 col-md-6", 353 | components$about$gerkelab 354 | )#, 355 | # box( 356 | # title = "About shinyDAG", 357 | # width = "12 col-md-6", 358 | # components$about$usage 359 | # ) 360 | ) 361 | ) 362 | ) 363 | ) 364 | } 365 | -------------------------------------------------------------------------------- /www/GerkeLab.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/GerkeLab.png -------------------------------------------------------------------------------- /www/_all-skins.gerkelab.min.css: -------------------------------------------------------------------------------- 1 | .skin-blue .main-header .navbar{background-color:#d3751c}.skin-blue .main-header .navbar .nav>li>a{color:#fff}.skin-blue .main-header .navbar .nav>li>a:hover,.skin-blue .main-header .navbar .nav>li>a:active,.skin-blue .main-header .navbar .nav>li>a:focus,.skin-blue .main-header .navbar .nav .open>a,.skin-blue .main-header .navbar .nav .open>a:hover,.skin-blue .main-header .navbar .nav .open>a:focus,.skin-blue .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-blue .main-header .navbar .sidebar-toggle{color:#fff}.skin-blue .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-blue .main-header .navbar .sidebar-toggle{color:#fff}.skin-blue .main-header .navbar .sidebar-toggle:hover{background-color:#bc6919}@media (max-width:767px){.skin-blue .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-blue .main-header .navbar .dropdown-menu li a{color:#fff}.skin-blue .main-header .navbar .dropdown-menu li a:hover{background:#bc6919}}.skin-blue .main-header .logo{background-color:#bc6919;color:#fff;border-bottom:0 solid transparent}.skin-blue .main-header .logo:hover{background-color:#b86618}.skin-blue .main-header li.user-header{background-color:#d3751c}.skin-blue .content-header{background:transparent}.skin-blue .wrapper,.skin-blue .main-sidebar,.skin-blue .left-side{background-color:#313439}.skin-blue .user-panel>.info,.skin-blue .user-panel>.info>a{color:#fff}.skin-blue .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-blue .sidebar-menu>li>a{border-left:3px solid transparent}.skin-blue .sidebar-menu>li:hover>a,.skin-blue .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#d3751c}.skin-blue .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-blue .sidebar a{color:#cacdd2}.skin-blue .sidebar a:hover{text-decoration:none}.skin-blue .treeview-menu>li>a{color:#a1a6ae}.skin-blue .treeview-menu>li.active>a,.skin-blue .treeview-menu>li>a:hover{color:#fff}.skin-blue .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-blue .sidebar-form input[type="text"],.skin-blue .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-blue .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-blue .sidebar-form input[type="text"]:focus,.skin-blue .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-blue .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-blue .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-blue.layout-top-nav .main-header>.logo{background-color:#d3751c;color:#fff;border-bottom:0 solid transparent}.skin-blue.layout-top-nav .main-header>.logo:hover{background-color:#ce731b}.skin-blue-light .main-header .navbar{background-color:#d3751c}.skin-blue-light .main-header .navbar .nav>li>a{color:#fff}.skin-blue-light .main-header .navbar .nav>li>a:hover,.skin-blue-light .main-header .navbar .nav>li>a:active,.skin-blue-light .main-header .navbar .nav>li>a:focus,.skin-blue-light .main-header .navbar .nav .open>a,.skin-blue-light .main-header .navbar .nav .open>a:hover,.skin-blue-light .main-header .navbar .nav .open>a:focus,.skin-blue-light .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-blue-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-blue-light .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-blue-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-blue-light .main-header .navbar .sidebar-toggle:hover{background-color:#bc6919}@media (max-width:767px){.skin-blue-light .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-blue-light .main-header .navbar .dropdown-menu li a{color:#fff}.skin-blue-light .main-header .navbar .dropdown-menu li a:hover{background:#bc6919}}.skin-blue-light .main-header .logo{background-color:#d3751c;color:#fff;border-bottom:0 solid transparent}.skin-blue-light .main-header .logo:hover{background-color:#ce731b}.skin-blue-light .main-header li.user-header{background-color:#d3751c}.skin-blue-light .content-header{background:transparent}.skin-blue-light .wrapper,.skin-blue-light .main-sidebar,.skin-blue-light .left-side{background-color:#e0e0e0}.skin-blue-light .content-wrapper,.skin-blue-light .main-footer{border-left:1px solid #eee}.skin-blue-light .user-panel>.info,.skin-blue-light .user-panel>.info>a{color:#616161}.skin-blue-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-blue-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-blue-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-blue-light .sidebar-menu>li:hover>a,.skin-blue-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-blue-light .sidebar-menu>li.active{border-left-color:#d3751c}.skin-blue-light .sidebar-menu>li.active>a{font-weight:600}.skin-blue-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-blue-light .sidebar a{color:#616161}.skin-blue-light .sidebar a:hover{text-decoration:none}.skin-blue-light .treeview-menu>li>a{color:#7a7a7a}.skin-blue-light .treeview-menu>li.active>a,.skin-blue-light .treeview-menu>li>a:hover{color:#000}.skin-blue-light .treeview-menu>li.active>a{font-weight:600}.skin-blue-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-blue-light .sidebar-form input[type="text"],.skin-blue-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-blue-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-blue-light .sidebar-form input[type="text"]:focus,.skin-blue-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-blue-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-blue-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-blue-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}}.skin-blue-light .main-footer{border-top-color:#eee}.skin-blue.layout-top-nav .main-header>.logo{background-color:#d3751c;color:#fff;border-bottom:0 solid transparent}.skin-blue.layout-top-nav .main-header>.logo:hover{background-color:#ce731b}.skin-black .main-header{-webkit-box-shadow:0 1px 1px rgba(0,0,0,0.05);box-shadow:0 1px 1px rgba(0,0,0,0.05)}.skin-black .main-header .navbar-toggle{color:#333}.skin-black .main-header .navbar-brand{color:#333;border-right:1px solid #eee}.skin-black .main-header .navbar{background-color:#fff}.skin-black .main-header .navbar .nav>li>a{color:#333}.skin-black .main-header .navbar .nav>li>a:hover,.skin-black .main-header .navbar .nav>li>a:active,.skin-black .main-header .navbar .nav>li>a:focus,.skin-black .main-header .navbar .nav .open>a,.skin-black .main-header .navbar .nav .open>a:hover,.skin-black .main-header .navbar .nav .open>a:focus,.skin-black .main-header .navbar .nav>.active>a{background:#fff;color:#999}.skin-black .main-header .navbar .sidebar-toggle{color:#333}.skin-black .main-header .navbar .sidebar-toggle:hover{color:#999;background:#fff}.skin-black .main-header .navbar>.sidebar-toggle{color:#333;border-right:1px solid #eee}.skin-black .main-header .navbar .navbar-nav>li>a{border-right:1px solid #eee}.skin-black .main-header .navbar .navbar-custom-menu .navbar-nav>li>a,.skin-black .main-header .navbar .navbar-right>li>a{border-left:1px solid #eee;border-right-width:0}.skin-black .main-header>.logo{background-color:#fff;color:#333;border-bottom:0 solid transparent;border-right:1px solid #eee}.skin-black .main-header>.logo:hover{background-color:#fcfcfc}@media (max-width:767px){.skin-black .main-header>.logo{background-color:#222;color:#fff;border-bottom:0 solid transparent;border-right:none}.skin-black .main-header>.logo:hover{background-color:#1f1f1f}}.skin-black .main-header li.user-header{background-color:#222}.skin-black .content-header{background:transparent;box-shadow:none}.skin-black .wrapper,.skin-black .main-sidebar,.skin-black .left-side{background-color:#313439}.skin-black .user-panel>.info,.skin-black .user-panel>.info>a{color:#fff}.skin-black .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-black .sidebar-menu>li>a{border-left:3px solid transparent}.skin-black .sidebar-menu>li:hover>a,.skin-black .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#fff}.skin-black .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-black .sidebar a{color:#cacdd2}.skin-black .sidebar a:hover{text-decoration:none}.skin-black .treeview-menu>li>a{color:#a1a6ae}.skin-black .treeview-menu>li.active>a,.skin-black .treeview-menu>li>a:hover{color:#fff}.skin-black .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-black .sidebar-form input[type="text"],.skin-black .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-black .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-black .sidebar-form input[type="text"]:focus,.skin-black .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-black .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-black .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-black .pace .pace-progress{background:#222}.skin-black .pace .pace-activity{border-top-color:#222;border-left-color:#222}.skin-black-light .main-header{-webkit-box-shadow:0 1px 1px rgba(0,0,0,0.05);box-shadow:0 1px 1px rgba(0,0,0,0.05)}.skin-black-light .main-header .navbar-toggle{color:#333}.skin-black-light .main-header .navbar-brand{color:#333;border-right:1px solid #eee}.skin-black-light .main-header .navbar{background-color:#fff}.skin-black-light .main-header .navbar .nav>li>a{color:#333}.skin-black-light .main-header .navbar .nav>li>a:hover,.skin-black-light .main-header .navbar .nav>li>a:active,.skin-black-light .main-header .navbar .nav>li>a:focus,.skin-black-light .main-header .navbar .nav .open>a,.skin-black-light .main-header .navbar .nav .open>a:hover,.skin-black-light .main-header .navbar .nav .open>a:focus,.skin-black-light .main-header .navbar .nav>.active>a{background:#fff;color:#999}.skin-black-light .main-header .navbar .sidebar-toggle{color:#333}.skin-black-light .main-header .navbar .sidebar-toggle:hover{color:#999;background:#fff}.skin-black-light .main-header .navbar>.sidebar-toggle{color:#333;border-right:1px solid #eee}.skin-black-light .main-header .navbar .navbar-nav>li>a{border-right:1px solid #eee}.skin-black-light .main-header .navbar .navbar-custom-menu .navbar-nav>li>a,.skin-black-light .main-header .navbar .navbar-right>li>a{border-left:1px solid #eee;border-right-width:0}.skin-black-light .main-header>.logo{background-color:#fff;color:#333;border-bottom:0 solid transparent;border-right:1px solid #eee}.skin-black-light .main-header>.logo:hover{background-color:#fcfcfc}@media (max-width:767px){.skin-black-light .main-header>.logo{background-color:#222;color:#fff;border-bottom:0 solid transparent;border-right:none}.skin-black-light .main-header>.logo:hover{background-color:#1f1f1f}}.skin-black-light .main-header li.user-header{background-color:#222}.skin-black-light .content-header{background:transparent;box-shadow:none}.skin-black-light .wrapper,.skin-black-light .main-sidebar,.skin-black-light .left-side{background-color:#e0e0e0}.skin-black-light .content-wrapper,.skin-black-light .main-footer{border-left:1px solid #eee}.skin-black-light .user-panel>.info,.skin-black-light .user-panel>.info>a{color:#616161}.skin-black-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-black-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-black-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-black-light .sidebar-menu>li:hover>a,.skin-black-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-black-light .sidebar-menu>li.active{border-left-color:#fff}.skin-black-light .sidebar-menu>li.active>a{font-weight:600}.skin-black-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-black-light .sidebar a{color:#616161}.skin-black-light .sidebar a:hover{text-decoration:none}.skin-black-light .treeview-menu>li>a{color:#7a7a7a}.skin-black-light .treeview-menu>li.active>a,.skin-black-light .treeview-menu>li>a:hover{color:#000}.skin-black-light .treeview-menu>li.active>a{font-weight:600}.skin-black-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-black-light .sidebar-form input[type="text"],.skin-black-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-black-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-black-light .sidebar-form input[type="text"]:focus,.skin-black-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-black-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-black-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-black-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}}.skin-green .main-header .navbar{background-color:#418c7a}.skin-green .main-header .navbar .nav>li>a{color:#fff}.skin-green .main-header .navbar .nav>li>a:hover,.skin-green .main-header .navbar .nav>li>a:active,.skin-green .main-header .navbar .nav>li>a:focus,.skin-green .main-header .navbar .nav .open>a,.skin-green .main-header .navbar .nav .open>a:hover,.skin-green .main-header .navbar .nav .open>a:focus,.skin-green .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-green .main-header .navbar .sidebar-toggle{color:#fff}.skin-green .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-green .main-header .navbar .sidebar-toggle{color:#fff}.skin-green .main-header .navbar .sidebar-toggle:hover{background-color:#397b6b}@media (max-width:767px){.skin-green .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-green .main-header .navbar .dropdown-menu li a{color:#fff}.skin-green .main-header .navbar .dropdown-menu li a:hover{background:#397b6b}}.skin-green .main-header .logo{background-color:#397b6b;color:#fff;border-bottom:0 solid transparent}.skin-green .main-header .logo:hover{background-color:#377768}.skin-green .main-header li.user-header{background-color:#418c7a}.skin-green .content-header{background:transparent}.skin-green .wrapper,.skin-green .main-sidebar,.skin-green .left-side{background-color:#313439}.skin-green .user-panel>.info,.skin-green .user-panel>.info>a{color:#fff}.skin-green .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-green .sidebar-menu>li>a{border-left:3px solid transparent}.skin-green .sidebar-menu>li:hover>a,.skin-green .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#418c7a}.skin-green .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-green .sidebar a{color:#cacdd2}.skin-green .sidebar a:hover{text-decoration:none}.skin-green .treeview-menu>li>a{color:#a1a6ae}.skin-green .treeview-menu>li.active>a,.skin-green .treeview-menu>li>a:hover{color:#fff}.skin-green .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-green .sidebar-form input[type="text"],.skin-green .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-green .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-green .sidebar-form input[type="text"]:focus,.skin-green .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-green .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-green .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-green-light .main-header .navbar{background-color:#418c7a}.skin-green-light .main-header .navbar .nav>li>a{color:#fff}.skin-green-light .main-header .navbar .nav>li>a:hover,.skin-green-light .main-header .navbar .nav>li>a:active,.skin-green-light .main-header .navbar .nav>li>a:focus,.skin-green-light .main-header .navbar .nav .open>a,.skin-green-light .main-header .navbar .nav .open>a:hover,.skin-green-light .main-header .navbar .nav .open>a:focus,.skin-green-light .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-green-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-green-light .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-green-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-green-light .main-header .navbar .sidebar-toggle:hover{background-color:#397b6b}@media (max-width:767px){.skin-green-light .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-green-light .main-header .navbar .dropdown-menu li a{color:#fff}.skin-green-light .main-header .navbar .dropdown-menu li a:hover{background:#397b6b}}.skin-green-light .main-header .logo{background-color:#418c7a;color:#fff;border-bottom:0 solid transparent}.skin-green-light .main-header .logo:hover{background-color:#3f8977}.skin-green-light .main-header li.user-header{background-color:#418c7a}.skin-green-light .content-header{background:transparent}.skin-green-light .wrapper,.skin-green-light .main-sidebar,.skin-green-light .left-side{background-color:#e0e0e0}.skin-green-light .content-wrapper,.skin-green-light .main-footer{border-left:1px solid #eee}.skin-green-light .user-panel>.info,.skin-green-light .user-panel>.info>a{color:#616161}.skin-green-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-green-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-green-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-green-light .sidebar-menu>li:hover>a,.skin-green-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-green-light .sidebar-menu>li.active{border-left-color:#418c7a}.skin-green-light .sidebar-menu>li.active>a{font-weight:600}.skin-green-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-green-light .sidebar a{color:#616161}.skin-green-light .sidebar a:hover{text-decoration:none}.skin-green-light .treeview-menu>li>a{color:#7a7a7a}.skin-green-light .treeview-menu>li.active>a,.skin-green-light .treeview-menu>li>a:hover{color:#000}.skin-green-light .treeview-menu>li.active>a{font-weight:600}.skin-green-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-green-light .sidebar-form input[type="text"],.skin-green-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-green-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-green-light .sidebar-form input[type="text"]:focus,.skin-green-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-green-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-green-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-green-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}}.skin-red .main-header .navbar{background-color:#ba2d0b}.skin-red .main-header .navbar .nav>li>a{color:#fff}.skin-red .main-header .navbar .nav>li>a:hover,.skin-red .main-header .navbar .nav>li>a:active,.skin-red .main-header .navbar .nav>li>a:focus,.skin-red .main-header .navbar .nav .open>a,.skin-red .main-header .navbar .nav .open>a:hover,.skin-red .main-header .navbar .nav .open>a:focus,.skin-red .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-red .main-header .navbar .sidebar-toggle{color:#fff}.skin-red .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-red .main-header .navbar .sidebar-toggle{color:#fff}.skin-red .main-header .navbar .sidebar-toggle:hover{background-color:#a2270a}@media (max-width:767px){.skin-red .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-red .main-header .navbar .dropdown-menu li a{color:#fff}.skin-red .main-header .navbar .dropdown-menu li a:hover{background:#a2270a}}.skin-red .main-header .logo{background-color:#a2270a;color:#fff;border-bottom:0 solid transparent}.skin-red .main-header .logo:hover{background-color:#9d2609}.skin-red .main-header li.user-header{background-color:#ba2d0b}.skin-red .content-header{background:transparent}.skin-red .wrapper,.skin-red .main-sidebar,.skin-red .left-side{background-color:#313439}.skin-red .user-panel>.info,.skin-red .user-panel>.info>a{color:#fff}.skin-red .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-red .sidebar-menu>li>a{border-left:3px solid transparent}.skin-red .sidebar-menu>li:hover>a,.skin-red .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#ba2d0b}.skin-red .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-red .sidebar a{color:#cacdd2}.skin-red .sidebar a:hover{text-decoration:none}.skin-red .treeview-menu>li>a{color:#a1a6ae}.skin-red .treeview-menu>li.active>a,.skin-red .treeview-menu>li>a:hover{color:#fff}.skin-red .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-red .sidebar-form input[type="text"],.skin-red .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-red .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-red .sidebar-form input[type="text"]:focus,.skin-red .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-red .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-red .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-red-light .main-header .navbar{background-color:#ba2d0b}.skin-red-light .main-header .navbar .nav>li>a{color:#fff}.skin-red-light .main-header .navbar .nav>li>a:hover,.skin-red-light .main-header .navbar .nav>li>a:active,.skin-red-light .main-header .navbar .nav>li>a:focus,.skin-red-light .main-header .navbar .nav .open>a,.skin-red-light .main-header .navbar .nav .open>a:hover,.skin-red-light .main-header .navbar .nav .open>a:focus,.skin-red-light .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-red-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-red-light .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-red-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-red-light .main-header .navbar .sidebar-toggle:hover{background-color:#a2270a}@media (max-width:767px){.skin-red-light .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-red-light .main-header .navbar .dropdown-menu li a{color:#fff}.skin-red-light .main-header .navbar .dropdown-menu li a:hover{background:#a2270a}}.skin-red-light .main-header .logo{background-color:#ba2d0b;color:#fff;border-bottom:0 solid transparent}.skin-red-light .main-header .logo:hover{background-color:#b52c0b}.skin-red-light .main-header li.user-header{background-color:#ba2d0b}.skin-red-light .content-header{background:transparent}.skin-red-light .wrapper,.skin-red-light .main-sidebar,.skin-red-light .left-side{background-color:#e0e0e0}.skin-red-light .content-wrapper,.skin-red-light .main-footer{border-left:1px solid #eee}.skin-red-light .user-panel>.info,.skin-red-light .user-panel>.info>a{color:#616161}.skin-red-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-red-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-red-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-red-light .sidebar-menu>li:hover>a,.skin-red-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-red-light .sidebar-menu>li.active{border-left-color:#ba2d0b}.skin-red-light .sidebar-menu>li.active>a{font-weight:600}.skin-red-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-red-light .sidebar a{color:#616161}.skin-red-light .sidebar a:hover{text-decoration:none}.skin-red-light .treeview-menu>li>a{color:#7a7a7a}.skin-red-light .treeview-menu>li.active>a,.skin-red-light .treeview-menu>li>a:hover{color:#000}.skin-red-light .treeview-menu>li.active>a{font-weight:600}.skin-red-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-red-light .sidebar-form input[type="text"],.skin-red-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-red-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-red-light .sidebar-form input[type="text"]:focus,.skin-red-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-red-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-red-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-red-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}}.skin-yellow .main-header .navbar{background-color:#d6a136}.skin-yellow .main-header .navbar .nav>li>a{color:#fff}.skin-yellow .main-header .navbar .nav>li>a:hover,.skin-yellow .main-header .navbar .nav>li>a:active,.skin-yellow .main-header .navbar .nav>li>a:focus,.skin-yellow .main-header .navbar .nav .open>a,.skin-yellow .main-header .navbar .nav .open>a:hover,.skin-yellow .main-header .navbar .nav .open>a:focus,.skin-yellow .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-yellow .main-header .navbar .sidebar-toggle{color:#fff}.skin-yellow .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-yellow .main-header .navbar .sidebar-toggle{color:#fff}.skin-yellow .main-header .navbar .sidebar-toggle:hover{background-color:#c99429}@media (max-width:767px){.skin-yellow .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-yellow .main-header .navbar .dropdown-menu li a{color:#fff}.skin-yellow .main-header .navbar .dropdown-menu li a:hover{background:#c99429}}.skin-yellow .main-header .logo{background-color:#c99429;color:#fff;border-bottom:0 solid transparent}.skin-yellow .main-header .logo:hover{background-color:#c59128}.skin-yellow .main-header li.user-header{background-color:#d6a136}.skin-yellow .content-header{background:transparent}.skin-yellow .wrapper,.skin-yellow .main-sidebar,.skin-yellow .left-side{background-color:#313439}.skin-yellow .user-panel>.info,.skin-yellow .user-panel>.info>a{color:#fff}.skin-yellow .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-yellow .sidebar-menu>li>a{border-left:3px solid transparent}.skin-yellow .sidebar-menu>li:hover>a,.skin-yellow .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#d6a136}.skin-yellow .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-yellow .sidebar a{color:#cacdd2}.skin-yellow .sidebar a:hover{text-decoration:none}.skin-yellow .treeview-menu>li>a{color:#a1a6ae}.skin-yellow .treeview-menu>li.active>a,.skin-yellow .treeview-menu>li>a:hover{color:#fff}.skin-yellow .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-yellow .sidebar-form input[type="text"],.skin-yellow .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-yellow .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-yellow .sidebar-form input[type="text"]:focus,.skin-yellow .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-yellow .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-yellow .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-yellow-light .main-header .navbar{background-color:#d6a136}.skin-yellow-light .main-header .navbar .nav>li>a{color:#fff}.skin-yellow-light .main-header .navbar .nav>li>a:hover,.skin-yellow-light .main-header .navbar .nav>li>a:active,.skin-yellow-light .main-header .navbar .nav>li>a:focus,.skin-yellow-light .main-header .navbar .nav .open>a,.skin-yellow-light .main-header .navbar .nav .open>a:hover,.skin-yellow-light .main-header .navbar .nav .open>a:focus,.skin-yellow-light .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-yellow-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-yellow-light .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-yellow-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-yellow-light .main-header .navbar .sidebar-toggle:hover{background-color:#c99429}@media (max-width:767px){.skin-yellow-light .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-yellow-light .main-header .navbar .dropdown-menu li a{color:#fff}.skin-yellow-light .main-header .navbar .dropdown-menu li a:hover{background:#c99429}}.skin-yellow-light .main-header .logo{background-color:#d6a136;color:#fff;border-bottom:0 solid transparent}.skin-yellow-light .main-header .logo:hover{background-color:#d59f32}.skin-yellow-light .main-header li.user-header{background-color:#d6a136}.skin-yellow-light .content-header{background:transparent}.skin-yellow-light .wrapper,.skin-yellow-light .main-sidebar,.skin-yellow-light .left-side{background-color:#e0e0e0}.skin-yellow-light .content-wrapper,.skin-yellow-light .main-footer{border-left:1px solid #eee}.skin-yellow-light .user-panel>.info,.skin-yellow-light .user-panel>.info>a{color:#616161}.skin-yellow-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-yellow-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-yellow-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-yellow-light .sidebar-menu>li:hover>a,.skin-yellow-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-yellow-light .sidebar-menu>li.active{border-left-color:#d6a136}.skin-yellow-light .sidebar-menu>li.active>a{font-weight:600}.skin-yellow-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-yellow-light .sidebar a{color:#616161}.skin-yellow-light .sidebar a:hover{text-decoration:none}.skin-yellow-light .treeview-menu>li>a{color:#7a7a7a}.skin-yellow-light .treeview-menu>li.active>a,.skin-yellow-light .treeview-menu>li>a:hover{color:#000}.skin-yellow-light .treeview-menu>li.active>a{font-weight:600}.skin-yellow-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-yellow-light .sidebar-form input[type="text"],.skin-yellow-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-yellow-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-yellow-light .sidebar-form input[type="text"]:focus,.skin-yellow-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-yellow-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-yellow-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-yellow-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}}.skin-purple .main-header .navbar{background-color:#001f3f}.skin-purple .main-header .navbar .nav>li>a{color:#fff}.skin-purple .main-header .navbar .nav>li>a:hover,.skin-purple .main-header .navbar .nav>li>a:active,.skin-purple .main-header .navbar .nav>li>a:focus,.skin-purple .main-header .navbar .nav .open>a,.skin-purple .main-header .navbar .nav .open>a:hover,.skin-purple .main-header .navbar .nav .open>a:focus,.skin-purple .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-purple .main-header .navbar .sidebar-toggle{color:#fff}.skin-purple .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-purple .main-header .navbar .sidebar-toggle{color:#fff}.skin-purple .main-header .navbar .sidebar-toggle:hover{background-color:#001226}@media (max-width:767px){.skin-purple .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-purple .main-header .navbar .dropdown-menu li a{color:#fff}.skin-purple .main-header .navbar .dropdown-menu li a:hover{background:#001226}}.skin-purple .main-header .logo{background-color:#001226;color:#fff;border-bottom:0 solid transparent}.skin-purple .main-header .logo:hover{background-color:#001020}.skin-purple .main-header li.user-header{background-color:#001f3f}.skin-purple .content-header{background:transparent}.skin-purple .wrapper,.skin-purple .main-sidebar,.skin-purple .left-side{background-color:#313439}.skin-purple .user-panel>.info,.skin-purple .user-panel>.info>a{color:#fff}.skin-purple .sidebar-menu>li.header{color:#606670;background:#282a2e}.skin-purple .sidebar-menu>li>a{border-left:3px solid transparent}.skin-purple .sidebar-menu>li:hover>a,.skin-purple .sidebar-menu>li.active>a{color:#fff;background:#2c2f34;border-left-color:#001f3f}.skin-purple .sidebar-menu>li>.treeview-menu{margin:0 1px;background:#3d4147}.skin-purple .sidebar a{color:#cacdd2}.skin-purple .sidebar a:hover{text-decoration:none}.skin-purple .treeview-menu>li>a{color:#a1a6ae}.skin-purple .treeview-menu>li.active>a,.skin-purple .treeview-menu>li>a:hover{color:#fff}.skin-purple .sidebar-form{border-radius:3px;border:1px solid #494d54;margin:10px 10px}.skin-purple .sidebar-form input[type="text"],.skin-purple .sidebar-form .btn{box-shadow:none;background-color:#494d54;border:1px solid transparent;height:35px}.skin-purple .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-purple .sidebar-form input[type="text"]:focus,.skin-purple .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-purple .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-purple .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}.skin-purple-light .main-header .navbar{background-color:#001f3f}.skin-purple-light .main-header .navbar .nav>li>a{color:#fff}.skin-purple-light .main-header .navbar .nav>li>a:hover,.skin-purple-light .main-header .navbar .nav>li>a:active,.skin-purple-light .main-header .navbar .nav>li>a:focus,.skin-purple-light .main-header .navbar .nav .open>a,.skin-purple-light .main-header .navbar .nav .open>a:hover,.skin-purple-light .main-header .navbar .nav .open>a:focus,.skin-purple-light .main-header .navbar .nav>.active>a{background:rgba(0,0,0,0.1);color:#f6f6f6}.skin-purple-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-purple-light .main-header .navbar .sidebar-toggle:hover{color:#f6f6f6;background:rgba(0,0,0,0.1)}.skin-purple-light .main-header .navbar .sidebar-toggle{color:#fff}.skin-purple-light .main-header .navbar .sidebar-toggle:hover{background-color:#001226}@media (max-width:767px){.skin-purple-light .main-header .navbar .dropdown-menu li.divider{background-color:rgba(255,255,255,0.1)}.skin-purple-light .main-header .navbar .dropdown-menu li a{color:#fff}.skin-purple-light .main-header .navbar .dropdown-menu li a:hover{background:#001226}}.skin-purple-light .main-header .logo{background-color:#001f3f;color:#fff;border-bottom:0 solid transparent}.skin-purple-light .main-header .logo:hover{background-color:#001c3a}.skin-purple-light .main-header li.user-header{background-color:#001f3f}.skin-purple-light .content-header{background:transparent}.skin-purple-light .wrapper,.skin-purple-light .main-sidebar,.skin-purple-light .left-side{background-color:#e0e0e0}.skin-purple-light .content-wrapper,.skin-purple-light .main-footer{border-left:1px solid #eee}.skin-purple-light .user-panel>.info,.skin-purple-light .user-panel>.info>a{color:#616161}.skin-purple-light .sidebar-menu>li{-webkit-transition:border-left-color .3s ease;-o-transition:border-left-color .3s ease;transition:border-left-color .3s ease}.skin-purple-light .sidebar-menu>li.header{color:#a0a0a0;background:#e0e0e0}.skin-purple-light .sidebar-menu>li>a{border-left:3px solid transparent;font-weight:600}.skin-purple-light .sidebar-menu>li:hover>a,.skin-purple-light .sidebar-menu>li.active>a{color:#212121;background:#e4e4e4}.skin-purple-light .sidebar-menu>li.active{border-left-color:#001f3f}.skin-purple-light .sidebar-menu>li.active>a{font-weight:600}.skin-purple-light .sidebar-menu>li>.treeview-menu{background:#e4e4e4}.skin-purple-light .sidebar a{color:#616161}.skin-purple-light .sidebar a:hover{text-decoration:none}.skin-purple-light .treeview-menu>li>a{color:#7a7a7a}.skin-purple-light .treeview-menu>li.active>a,.skin-purple-light .treeview-menu>li>a:hover{color:#000}.skin-purple-light .treeview-menu>li.active>a{font-weight:600}.skin-purple-light .sidebar-form{border-radius:3px;border:1px solid #eee;margin:10px 10px}.skin-purple-light .sidebar-form input[type="text"],.skin-purple-light .sidebar-form .btn{box-shadow:none;background-color:#fff;border:1px solid transparent;height:35px}.skin-purple-light .sidebar-form input[type="text"]{color:#666;border-top-left-radius:2px;border-top-right-radius:0;border-bottom-right-radius:0;border-bottom-left-radius:2px}.skin-purple-light .sidebar-form input[type="text"]:focus,.skin-purple-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{background-color:#fff;color:#666}.skin-purple-light .sidebar-form input[type="text"]:focus+.input-group-btn .btn{border-left-color:#fff}.skin-purple-light .sidebar-form .btn{color:#999;border-top-left-radius:0;border-top-right-radius:2px;border-bottom-right-radius:2px;border-bottom-left-radius:0}@media (min-width:768px){.skin-purple-light.sidebar-mini.sidebar-collapse .sidebar-menu>li>.treeview-menu{border-left:1px solid #eee}} -------------------------------------------------------------------------------- /www/examples/README.md: -------------------------------------------------------------------------------- 1 | ## Creating Examples 2 | 3 | To create a new example, run ShinyDAG locally using the shinydag dev docker file. 4 | 5 | Set up your example and then save it as a bookmark. 6 | 7 | Note the URL created by shiny for the bookmark, it should end with 8 | 9 | ``` 10 | ?_state_id_=9d49cb0ba72b00f2 11 | ``` 12 | 13 | Navigate to the `shiny_bookmarks` folder and find the folder with the bookmark token, e.g. `9d49cb0ba72b00f2`. 14 | 15 | Copy `values.rds` to `www/examples` and give the file a descriptive name. 16 | These names are used for the shiny inputs, so keep the characters sane (and no spaces). 17 | 18 | Also, save the DAG image into `www/examples` with the same name (not required but a good idea). 19 | 20 | Finally, add the description text to `www/examples/examples.yml`. 21 | Here's an example template that you can copy. 22 | Note that if you can use HTML in the `description`, but it needs to be valid or it will cause problems on the page. 23 | 24 | ```yaml 25 | - name: Classic Confounding 26 | description: > 27 | This is a description of classic confounding. Descriptions may include 28 | HTML. 29 | file: classic-confounding.rds 30 | image: classic-confounding.png 31 | ``` -------------------------------------------------------------------------------- /www/examples/classic-confounding.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/classic-confounding.png -------------------------------------------------------------------------------- /www/examples/classic-confounding.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/classic-confounding.rds -------------------------------------------------------------------------------- /www/examples/differential-loss-to-follow-up.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/differential-loss-to-follow-up.png -------------------------------------------------------------------------------- /www/examples/differential-loss-to-follow-up.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/differential-loss-to-follow-up.rds -------------------------------------------------------------------------------- /www/examples/examples.yml: -------------------------------------------------------------------------------- 1 | - name: Classic Confounding 2 | description: > 3 | This depicts classic confounding, where a confounder C is a common cause of exposure (E) and outcome (Y). 4 | file: classic-confounding.rds 5 | image: classic-confounding.png 6 | 7 | - name: Differential Loss to Follow-Up 8 | description: > 9 | This depicts differential loss to follow up, where patients may be censored (C) depending on their value of L. 10 | file: differential-loss-to-follow-up.rds 11 | image: differential-loss-to-follow-up.png 12 | 13 | - name: Mediator with Confounding 14 | description: > 15 | This shows a mediator with confounding, where the variable M mediates the effect of E on Y, which is confounded by the variable C. 16 | file: mediator-with-confounding.rds 17 | image: mediator-with-confounding.png 18 | 19 | - name: Selection Bias 20 | description: > 21 | This depicts classic selection bias, where C denotes criteria under which the data are observed which, in turn, is a downstream consequence of exposure (E) and outcome (D). 22 | file: selection-bias.rds 23 | image: selection-bias.png 24 | -------------------------------------------------------------------------------- /www/examples/mediator-with-confounding.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/mediator-with-confounding.png -------------------------------------------------------------------------------- /www/examples/mediator-with-confounding.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/mediator-with-confounding.rds -------------------------------------------------------------------------------- /www/examples/selection-bias.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/selection-bias.png -------------------------------------------------------------------------------- /www/examples/selection-bias.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/GerkeLab/shinyDAG/2e1b71c1ad902575fdeaaf799be47d4563d15ef0/www/examples/selection-bias.rds -------------------------------------------------------------------------------- /www/shinydag.css: -------------------------------------------------------------------------------- 1 | @import url('https://fonts.googleapis.com/css?family=Lato:300,400,400i,700,700i'); 2 | 3 | @media (min-width: 768px) and (max-width: 991px) { 4 | #shinydag-toolbar-node-list-action { 5 | padding-top: 32px; 6 | } 7 | } 8 | 9 | .debug-buttons { 10 | position: fixed; 11 | top: 0; 12 | left: 50%; 13 | z-index: 10000; 14 | } 15 | 16 | /* ---- GerkeLab Admin LTE Theme Tweaks ---- */ 17 | body, h1, h2, h3, h4, h5, h6, .h1, .h2, .h3, .h4, .h5, .h6, .main-header .logo { 18 | font-family: Lato, sans-serif; 19 | } 20 | 21 | .main-header > .logo { 22 | color: #989898 !important; 23 | text-decoration: none; 24 | font-weight: bold; 25 | } 26 | 27 | .main-header { 28 | position: fixed; 29 | width: 100%; 30 | box-shadow: 0 3px 3px rgba(0,0,0,0.1) !important; 31 | -webkit-box-shadow: 0 3px 3px rgba(0,0,0,0.1) !important; 32 | } 33 | 34 | .wrapper, .content-wrapper { 35 | min-height: 100vh !important; 36 | height: 100% !important; 37 | background-color: #f0f0f0 !important; 38 | } 39 | 40 | @media (max-width:767px) { 41 | .content-wrapper { 42 | padding-top: 100px; 43 | } 44 | } 45 | @media (min-width:768px) { 46 | .content-wrapper { 47 | padding-top: 50px; 48 | } 49 | } 50 | 51 | .skin-black .main-header .navbar .navbar-custom-menu .navbar-nav > li > a, 52 | .skin-black .main-header .navbar .navbar-right > li > a { 53 | border-left: none; 54 | } 55 | 56 | .gerkelab-logo { 57 | background: url("GerkeLab.png"); 58 | background-size: contain; 59 | width: 100px; 60 | height: 100px; 61 | position: absolute; 62 | bottom: 25px; 63 | left: 65px; 64 | filter: drop-shadow(0 3px 4px rgba(0,0,0,0.2)); 65 | transition: z-index 0s, left 0.25s ease-in-out, filter 0.25s ease-in-out, opacity 1s ease-in-out; 66 | z-index: 1000; 67 | opacity: 1; 68 | } 69 | 70 | .sidebar-collapse .gerkelab-logo { 71 | transition: z-index 0s 0.5s, left 0.25s ease-in-out, filter 0.25s ease-in-out; 72 | z-index: 0; 73 | left: 2%; 74 | bottom: 25px; 75 | } 76 | 77 | .sidebar-collapse .gerkelab-logo:hover { 78 | filter: drop-shadow(0 0 1px rgba(0,0,0,0.2)); 79 | } 80 | 81 | @media (max-width: 767px) { 82 | .gerkelab-logo { 83 | z-index: 0; 84 | opacity: 0; 85 | } 86 | } 87 | 88 | .disable-buttons { 89 | pointer-events: none; 90 | } 91 | 92 | .disabled { 93 | pointer-events: none; 94 | } 95 | 96 | #shiny-tab-sketch .box { 97 | margin-bottom: 100px; 98 | } 99 | 100 | .dag-preview-tikz { 101 | min-height: 400px; 102 | } 103 | 104 | .example-image { 105 | text-align: center; 106 | } 107 | 108 | .example-image img { 109 | width: 80%; 110 | max-width: 500px; 111 | } 112 | 113 | /* ---- ShinyDAG specific tweaks ---- */ 114 | 115 | #edge_aes_ui label { 116 | color: #777; 117 | font-weight: normal; 118 | } 119 | 120 | #showPreviewContainer { 121 | padding-top: 32px; 122 | } 123 | 124 | .dagpreview-download-ui { 125 | padding-top: 25px; 126 | } 127 | 128 | #node_delete { 129 | margin-top: 20px; 130 | color: #FFF 131 | } 132 | 133 | #edge_btn { 134 | margin-top: 25px; 135 | color: #FFF 136 | } 137 | 138 | #ui_edge_swap_btn { 139 | margin-top: 25px; 140 | } 141 | 142 | @media (min-width: 768px) { 143 | #node_delete { 144 | margin-left: -25px; 145 | } 146 | } 147 | 148 | .edge-selector-hint { 149 | font-size: 28px; 150 | line-height: 14px; 151 | padding-left: 4px; 152 | vertical-align: top; 153 | } 154 | 155 | .help-block { 156 | padding-top: 0; 157 | font-style: italic; 158 | } 159 | 160 | .help-block.text-warning { 161 | color: #db8b0b; 162 | background-color: #db8b0b20; 163 | } 164 | 165 | .help-block.text-danger { 166 | color: #d33724; 167 | background-color: #d3372420; 168 | } 169 | 170 | #edge_list_helptext .help-block, #node_list_helptext .help-block { 171 | padding: 0.5em; 172 | border-radius: 3px; 173 | } 174 | 175 | .btn-text { 176 | padding-left: 5px; 177 | } 178 | 179 | .dag-diagnostic__result + .dag-diagnostic__result { 180 | margin-top: 2em; 181 | } 182 | 183 | /* make in-app debug pane resizable */ 184 | #undo_rv-v_stack { 185 | resize: vertical; 186 | overflow-y: auto; 187 | height: 160px; 188 | } 189 | 190 | @media (min-width: 992px) and (max-width: 1825px) { 191 | .btn-text { 192 | display: none; 193 | } 194 | } 195 | 196 | .gerkelab-spinner { 197 | margin: auto; 198 | width: 100px; 199 | height: 100px; 200 | background: url("GerkeLab.png"); 201 | background-size: cover; 202 | -webkit-animation-name: spin; 203 | -webkit-animation-duration: 4000ms; 204 | -webkit-animation-iteration-count: infinite; 205 | -webkit-animation-timing-function: linear; 206 | -moz-animation-name: spin; 207 | -moz-animation-duration: 4000ms; 208 | -moz-animation-iteration-count: infinite; 209 | -moz-animation-timing-function: linear; 210 | -ms-animation-name: spin; 211 | -ms-animation-duration: 4000ms; 212 | -ms-animation-iteration-count: infinite; 213 | -ms-animation-timing-function: linear; 214 | 215 | animation-name: spin; 216 | animation-duration: 4000ms; 217 | animation-iteration-count: infinite; 218 | animation-timing-function: linear; 219 | } 220 | @-ms-keyframes spin { 221 | from { -ms-transform: rotate(0deg); } 222 | to { -ms-transform: rotate(-360deg); } 223 | } 224 | @-moz-keyframes spin { 225 | from { -moz-transform: rotate(0deg); } 226 | to { -moz-transform: rotate(-360deg); } 227 | } 228 | @-webkit-keyframes spin { 229 | from { -webkit-transform: rotate(0deg); } 230 | to { -webkit-transform: rotate(-360deg); } 231 | } 232 | @keyframes spin { 233 | from { 234 | transform:rotate(0deg); 235 | } 236 | to { 237 | transform:rotate(-360deg); 238 | } 239 | } 240 | 241 | .alert-edge { 242 | animation: fadeout 5s; 243 | -moz-animation: fadeout 5s; 244 | -webkit-animation: fadeout 5s; 245 | -o-animation: fadeout 5s; 246 | } 247 | 248 | @keyframes fadeout { 249 | 0% { 250 | opacity: 1; 251 | } 252 | 75% { 253 | opacity: 1; 254 | } 255 | 100% { 256 | opacity: 0; 257 | } 258 | } 259 | 260 | @-moz-keyframes fadeout { 261 | 0% { 262 | opacity: 1; 263 | } 264 | 75% { 265 | opacity: 1; 266 | } 267 | 100% { 268 | opacity: 0; 269 | } 270 | } 271 | 272 | @-webkit-keyframes fadeout { 273 | 0% { 274 | opacity: 1; 275 | } 276 | 75% { 277 | opacity: 1; 278 | } 279 | 100% { 280 | opacity: 0; 281 | } 282 | } -------------------------------------------------------------------------------- /www/shinydag.js: -------------------------------------------------------------------------------- 1 | const set_input_focus = (id) => { 2 | const el = document.getElementById(id); 3 | if (el) { 4 | el.focus(); 5 | } 6 | }; 7 | 8 | const wrap_btn_text_in_span = (id, text) => { 9 | var $el = $("#" + id); 10 | $el.html([$el.children()[0], "" + text + ""]); 11 | }; 12 | 13 | $( document ).ready(function() { 14 | setTimeout(function() {wrap_btn_text_in_span("downloadButton", "Download")}, 1000); 15 | setTimeout(function() {wrap_btn_text_in_span("\\._bookmark_", "Bookmark")}, 1000); 16 | }); 17 | 18 | // Block name change updates while Shiny is re-rendering to avoid wonkiness 19 | var text_input_timeout; 20 | $(document).on("shiny:busy", (e) => { 21 | text_input_timeout = setTimeout(() => { 22 | $("#node_list_node_name").prop("disabled", true); 23 | }, 500); 24 | }); 25 | $(document).on("shiny:idle", (e) => { 26 | clearTimeout(text_input_timeout); 27 | $("#node_list_node_name").prop("disabled", false); 28 | }); 29 | 30 | // Block node change buttons when updating names to avoid infinite looping wonkiness 31 | // disables buttons when user starts typing in text box 32 | $("#node_list_node_name").keydown(() => { 33 | $("#shinydag-toolbar-node-list-action button").prop("disabled", true); 34 | }); 35 | 36 | // re-enable buttons when Shiny updates or the text bar loses focus (in case no change) 37 | $(document).on("shiny:value", () => { 38 | $("#shinydag-toolbar-node-list-action button").prop("disabled", false); 39 | }); 40 | $("#node_list_node_name").blur(() => { 41 | $("#shinydag-toolbar-node-list-action button").prop("disabled", false); 42 | }); 43 | 44 | // Block undo/redo buttons during Shiny updates as well 45 | var undo_disable_timeout = null; 46 | $("#undo_rv-history_back, #undo_rv-history_forward").on("click", () => { 47 | undo_disable_timeout = setTimeout(() => { 48 | $("#undo_rv-history_back").parent().addClass("disable-buttons"); 49 | }, 10); 50 | }) 51 | 52 | // Bock undo/redo with a delay for general Shiny updates 53 | $(document).on("shiny:busy", () => { 54 | if (!undo_disable_timeout) { 55 | undo_disable_timeout = setTimeout(() => { 56 | $("#undo_rv-history_back").parent().addClass("disable-buttons"); 57 | }, 250); 58 | } 59 | }); 60 | 61 | // re-enable undo/redo buttons when Shiny is idle 62 | $(document).on("shiny:idle", () => { 63 | clearTimeout(undo_disable_timeout); 64 | undo_disable_timeout = null; 65 | $("#undo_rv-history_back").parent().removeClass("disable-buttons"); 66 | }); 67 | 68 | // Animate logo when app is busy 69 | var app_busy_timeout; 70 | $(document).on("shiny:busy", e => { 71 | app_busy_timeout = setTimeout(() => { 72 | $(".gerkelab-logo").addClass("gerkelab-spinner"); 73 | }, 500); 74 | }); 75 | $(document).on("shiny:idle", e => { 76 | clearTimeout(app_busy_timeout); 77 | $(".gerkelab-logo").removeClass("gerkelab-spinner"); 78 | }); 79 | --------------------------------------------------------------------------------