app commit

.Renviron

@@ -0,0 +1,2 @@
+USER="shiny"
+PASSWORD="beez"

.Rprofile

@@ -0,0 +1,12 @@
+if (file.exists("renv")) {
+  source("renv/activate.R")
+} else {
+  # The `renv` directory is automatically skipped when deploying with rsconnect.
+  message("No 'renv' directory found; renv won't be activated.")
+}
+
+# Allow absolute module imports (relative to the app root).
+options(box.path = getwd())
+
+# Enable auto reloading via Rhino 1.7
+options(shiny.autoreload = TRUE)

.github/workflows/rhino-test.yml

@@ -0,0 +1,72 @@
+name: Rhino Test
+on: push
+permissions:
+  contents: read
+jobs:
+  main:
+    name: Run linters and tests
+    runs-on: ubuntu-22.04
+    steps:
+      - name: Checkout repo
+        uses: actions/checkout@v4
+
+      - name: Setup system dependencies
+        run: |
+          packages=(
+            # List each package on a separate line.
+          )
+          sudo apt-get update
+          sudo apt-get install --yes "${packages[@]}"
+
+      - name: Setup R
+        uses: r-lib/actions/setup-r@v2
+        with:
+          r-version: renv
+
+      - name: Setup R dependencies
+        uses: r-lib/actions/setup-renv@v2
+
+      - name: Setup Node
+        uses: actions/setup-node@v3
+        with:
+          node-version: 20
+
+      - name: Lint R
+        if: always()
+        shell: Rscript {0}
+        run: rhino::lint_r()
+
+      - name: Lint JavaScript
+        if: always()
+        shell: Rscript {0}
+        run: rhino::lint_js()
+
+      - name: Lint Sass
+        if: always()
+        shell: Rscript {0}
+        run: rhino::lint_sass()
+
+      - name: Build JavaScript
+        if: always()
+        shell: Rscript {0}
+        run: rhino::build_js()
+
+      - name: Build Sass
+        if: always()
+        shell: Rscript {0}
+        run: rhino::build_sass()
+
+      - name: Run R unit tests
+        if: always()
+        shell: Rscript {0}
+        run: rhino::test_r()
+
+      - name: Run Cypress end-to-end tests
+        if: always()
+        uses: cypress-io/github-action@v6
+        with:
+          working-directory: .rhino # Created by earlier commands which use Node.js
+          start: npm run run-app
+          project: ../tests
+          wait-on: 'http://localhost:3333/'
+          wait-on-timeout: 60

.lintr

@@ -0,0 +1,5 @@
+linters:
+  linters_with_defaults(
+    line_length_linter = line_length_linter(100),
+    object_usage_linter = NULL  # Does not work with `box::use()`.
+  )

.renvignore

@@ -0,0 +1,3 @@
+# Only use `dependencies.R` to infer project dependencies.
+*
+!dependencies.R

.rscignore

@@ -0,0 +1,7 @@
+.github
+.lintr
+.renvignore
+.Renviron
+.rhino
+.rscignore
+tests

app.R

@@ -0,0 +1,2 @@
+# Rhino / shinyApp entrypoint. Do not edit.
+rhino::app()

app/logic/__init__.R

@@ -0,0 +1,2 @@
+# Logic: application code independent from Shiny.
+# https://go.appsilon.com/rhino-project-structure

app/logic/utils.R

@@ -0,0 +1,49 @@
+box::use(
+  ggplot2,
+  grid,
+  png,
+)
+
+#' @export
+get_png_br <- function(filename) {
+  grid$rasterGrob(png$readPNG(filename),
+                   interpolate = TRUE,
+                   x = grid$unit(1, "npc"),
+                   y = grid$unit(0, "npc") + grid$unit(35, "pt"),
+                   height = grid$unit(50, "pt"),
+                   hjust = 1,
+                   vjust = 1
+  )
+}
+
+#' @export
+get_png_tr <- function(filename) {
+  grid$rasterGrob(png$readPNG(filename),
+                  interpolate = TRUE,
+                  x = grid$unit(1, "npc") - grid$unit(10, "pt"),
+                  y = grid$unit(1, "npc"),
+                  height = grid$unit(50, "pt"),
+                  hjust = 1,
+                  vjust = 1
+  )
+}
+
+#' @export
+add_shiny_logo <- function(logo) {
+  list(
+    ggplot2$annotation_custom(logo),
+    ggplot2$coord_cartesian(clip = "off"),
+    ggplot2$theme(plot.margin = ggplot2$unit(c(1, 1, 3, 1), "lines"))
+  )
+}
+
+#' @export
+watermark_br <- get_png_br("../shinybeez/app/static/img/shinybeez-watermark-alpha.png")
+
+#' @export
+watermark_tr <- get_png_tr("../shinybeez/app/static/img/shinybeez-watermark-alpha.png")
+
+#' @export
+geomean <- function(x) {
+  return(round(exp(mean(log((x + 1)))) - 1, 2))
+}

app/logic/validate.R

@@ -0,0 +1,145 @@
+box::use(
+  assertthat,
+  beezdiscounting,
+  dplyr,
+  readr,
+  tidyr,
+)
+
+#' @export
+check_data <- function(dat, type = "demand") {
+  if (type == "demand") {
+    if (length(unique(dat$id)) == length(dat$id)) {
+      if ("group" %in% colnames(dat)) {
+        return_msg <- assertthat$validate_that(
+          all(colnames(dat)[1:2] == c("id", "group")),
+          msg = "The first two columns do not match `id`, `group`"
+          )
+        if (is.character(return_msg)) return(return_msg)
+        dat <- dplyr$relocate(dat, group, .after = id)
+        return_msg <- assertthat$validate_that(
+          all(sapply(readr$parse_number(colnames(dat)[3:length(colnames(dat))]), is.numeric)),
+          msg = "The column names are not numeric"
+          )
+        if (is.character(return_msg)) return(return_msg)
+      } else {
+        return_msg <- assertthat$validate_that(
+          colnames(dat)[1] == c("id"),
+          msg = "The first column is not `id`"
+          )
+        if (is.character(return_msg)) return(return_msg)
+        return_msg <- assertthat$validate_that(
+          all(sapply(readr$parse_number(colnames(dat)[2:length(colnames(dat))]), is.numeric)),
+          msg = "The column names are not numeric"
+        )
+        if (is.character(return_msg)) return(return_msg)
+      }
+    } else {
+      if ("group" %in% colnames(dat)){
+        return_msg <- assertthat$validate_that(
+          all(colnames(dat) == c("id", "group", "x", "y")),
+          msg = "Check colnames `id`, `group`, `x`, and `y` in data"
+          )
+      } else {
+        return_msg <- assertthat$validate_that(
+          all(colnames(dat) == c("id", "x", "y")),
+          msg = "Check colnames `id`, `x`, and `y` are ordered in  data"
+          )
+      }
+    }
+  } else {
+    # check if file has correct id columns
+    return_msg <- assertthat$validate_that(
+        any(colnames(dat) %in% c("subjectid", "ResponseId")),
+        msg = "Check colnames for 'subjectid' or 'ResponseId' in data"
+      )
+    if ("subjectid" %in% colnames(dat)) {
+      # check if 28 or 3 columns wide
+      return_msg <- assertthat$validate_that(
+        ncol(dat) == 28 | ncol(dat) == 3,
+        msg = "Number of columns does not appear to match the template"
+      )
+    } else {
+      # check if columns match the qualtrics template output
+      return_msg <- assertthat$validate_that(
+        all(paste0("I", c(1:31)) %in% colnames(dat)),
+        msg = "Check to make sure you are using the correct Qualtrics template."
+      )
+    }
+  }
+  if (is.character(return_msg)) {
+    return(return_msg)
+  } else {
+    return(TRUE)
+  }
+}
+
+#' @export
+rename_cols <- function(dat) {
+  # check if dat is wider than it is long
+  if (length(unique(dat$id)) == length(dat$id)) {
+    lcols <- length(colnames(dat))
+    if ("group" %in% colnames(dat)) {
+      dat <- dplyr$relocate(dat, group, .after = id)
+      colnames(dat)[3:lcols] <- readr$parse_number(colnames(dat)[3:lcols])
+    } else {
+      colnames(dat)[2:lcols] <- readr$parse_number(colnames(dat)[2:lcols])
+    }
+  }
+  dat
+}
+
+#' @export
+reshape_data <- function(dat, type = "demand") {
+  if  (type == "demand") {
+    # check if dat is wider than it is long
+    if (length(unique(dat$id)) == length(dat$id)) {
+     if ("group" %in% colnames(dat)) {
+      dat |>
+        tidyr$pivot_longer(
+          cols = 3:ncol(dat),
+          names_to = "x",
+          values_to = "y")
+      } else {
+        dat |>
+          tidyr$pivot_longer(
+            cols = 2:ncol(dat),
+            names_to = "x",
+            values_to = "y")
+      }
+    } else {
+      dat
+    }
+  } else if (type == "discounting") {
+    if (ncol(dat) == 28) {
+      dat |>
+        beezdiscounting$wide_to_long_mcq(dat = _)
+    } else {
+      dat
+    }
+  }
+}
+
+#' @export
+retype_data <- function(dat) {
+  dat$x <- readr$parse_number(dat$x)
+  if ("group" %in% colnames(dat)) {
+    dat |>
+      dplyr$mutate(
+        id = as.factor(id),
+        group = as.factor(group),
+        x = as.numeric(x),
+        y = as.numeric(y)
+      )
+  } else {
+    dat |>
+      dplyr$mutate(
+        id = as.factor(id),
+        x = as.numeric(x),
+        y = as.numeric(y)
+      )
+  }
+}
+
+#' @export
+k_values <- c(1.5, 2, 2.5, 3, 3.5, 4)

app/main.R

@@ -0,0 +1,85 @@
+box::use(
+  bslib,
+  rhino,
+  shiny,
+)
+
+box::use(
+  app/view/demand,
+  app/view/discounting,
+  app/view/info,
+  app/view/welcome,
+)
+
+#' @export
+ui <- function(id) {
+  ns <- shiny$NS(id)
+  rhino$log$info("Starting")
+  bslib$page_navbar(
+    title = shiny$tags$span(
+      style = "font-size: 200%;",
+      shiny$tags$img(
+        src = "static/img/hex-shinybeez.png",
+        width = "95px",
+        height = "auto",
+        class = "me-3",
+        alt = "Shiny Beez"
+      ),
+      "Shinybeez"
+    ),
+    id = "nav",
+    sidebar = bslib$sidebar(
+      id = "sidebar",
+      open = TRUE,
+      width = 350,
+      shiny$conditionalPanel(
+        "input.nav === 'Welcome'",
+        welcome$sidebar_ui(ns("welcomeui"))
+      ),
+      shiny$conditionalPanel(
+        "input.nav === 'Demand'",
+        demand$sidebar_ui(ns("demand")),
+      ),
+      shiny$conditionalPanel(
+        "input.nav === 'Discounting'",
+        discounting$sidebar_ui(ns("discounting"))
+      )
+    ),
+    bslib$nav_panel(
+      title = "Welcome",
+      welcome$body_ui(ns("welcomebody"))
+    ),
+    bslib$nav_panel(
+      value = "Demand",
+      title = "Demand",
+      demand$navpanel_ui(ns("demand"))
+    ),
+    bslib$nav_panel(
+      value = "Discounting",
+      title = "Discounting",
+      discounting$navpanel_ui(ns("discounting"))
+    ),
+    bslib$nav_spacer(),
+    bslib$nav_item(
+      bslib$input_dark_mode(id = "dark_mode", mode = "light")
+    ),
+    info$ui(ns("info"))
+  )
+}
+
+#' @export
+server <- function(id) {
+  shiny$moduleServer(id, function(input, output, session) {
+    ns <- session$ns
+    welcome$body_server("welcomebody")
+    session$userData$data <- shiny$reactiveValues()
+    demand$sidebar_server("demand")
+    demand$navpanel_server("demand")
+    discounting$sidebar_server("discounting")
+    discounting$navpanel_server("discounting")
+    info$server("info")
+    session$onSessionEnded(function() {
+      rhino$log$info("Stopping")
+    })
+  })
+}