Version 1.0.0 (#13)

Version 1.0.0

.gitignore

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

.travis.yml

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

Dockerfile

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

R/aes_ui.R

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

R/columns.R

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