t4c/app.R

library(shinysense)
library(htmlwidgets)
library(shiny)
library(dplyr)
library(shinyjs)
library(ggplot2)

# ---- APP PARAMETERS ----
APP_TITLE <- "App Title"
HELP_TEXT <- "Some guidance text can go here"
SWIPES_MEAN <- c(
  "left" = -1L,
  "right" = 1L
)

top_male_names <- readRDS(here::here("data/top_male_names.rds"))
random_name <- function() sample(top_male_names, 1)
possessive_name <- function(x) if (substr(x, nchar(x), nchar(x)) == "s") paste0(x, "'") else paste0(x, "'s")

questions <- readxl::read_xlsx(here::here("docs/questions.xlsx")) %>%
  arrange(order)

plot_swipe_results <- function(questions, results, SWIPES_MEAN) {
  n_category <- questions %>% group_by(Category) %>% count()

  qx <- questions %>%
    left_join(results, by = c(id = "question_id")) %>%
    mutate(score = -SWIPES_MEAN[swipe]) %>%
    group_by(Category) %>%
    summarize(score = mean(score)) %>%
    left_join(n_category, by = "Category")

  ggplot(qx) +
    aes(x = Category, y = score, color = score) +
    geom_point(size = 5) +
    scale_y_continuous(limits = c(-1, 1), breaks = -1:1, labels = c("Acceptable", "Ambivalent", "Undesirable")) +
    scale_color_gradient2(low = "#82c878", high = "#eb1455", mid = "#ffcd5a", limits = c(-1, 1)) +
    coord_flip() +
    guides(color = FALSE) +
    labs(x=NULL, y=NULL) +
    hrbrthemes::theme_ipsum_ps(base_size = 26, axis_title_just = "cc") +
    facet_wrap(~ Category, ncol = 1, scales = "free_y") +
    theme(
      panel.grid.minor.x = element_blank(),
      panel.grid.major.x = element_blank(),
      axis.text.y = element_blank()
    )
}

phone_container <- function(...) {
  div(
    class = "phone-container",
    div(
      class = "marvel-device iphone8plus black",
      div(class = "top-bar"),
      div(class = "sleep"),
      div(class = "volume"),
      div(class = "camera"),
      div(class = "sensor"),
      div(class = "speaker"),
      div(class = "screen", ...),
      div(class = "home"),
      div(class = "bottom-bar")
    )
  )
}

swipe_help_row_div <- div(
  class = "bottom-help text-moffitt-grey",
  div(class = "bottom-help-left", img(src = "/images/swipe-left.svg", width = "50px"), p("Bad")),
  div(class = "bottom-help-right", img(src = "/images/swipe-right.svg", width = "50px"), p("Okay")),
  div(class = "bottom-help-middle", span("Swipe Card", class = "bottom-help-middle-text"))
)

source("screens.R", local = TRUE)

ui <- fixedPage(
  includeCSS("www/css/devices.min.css"),
  includeCSS("www/css/t4c.css"),
  includeCSS("www/css/moffitt-colors.css"),
  includeCSS("www/css/animate.css"),
  shinyjs::useShinyjs(),
  tags$link(rel = "stylesheet", type = "text/css", href = "https://fonts.googleapis.com/css?family=IBM+Plex+Sans:100,100i,200,200i,300,300i,400,400i,500,500i,600,600i,700,700i"),
  tags$link(rel = "stylesheet", type = "text/css", href = "https://fonts.googleapis.com/css?family=Amatic+SC:400,700|Coming+Soon"),

  p(),
  phone_container(
    screens[["splash-overlay"]],
    screens[["app-intro"]],
    screens[["app-main"]],
    screens[["app-story"]],
    screens[["app-results"]]
  ),
  hr(),
  actionButton("toggle_splash", "Toggle Splash"),
  actionButton("back", "Back"),
  actionButton("jump_results", "Jump to Last Results"),
  h4("Answer History"),
  dataTableOutput("results_table")
)


server <- function(input, output, session) {
  app_data <- reactiveValues(
    init = 1L,
    iter = 1L,
    results = data_frame(question_id = integer(), swipe = character()),
    complete = FALSE,
    splash = TRUE,
    screen_prev = NULL,
    screen_active = "splash-overlay",
    screen_next = NULL
  )

  app_screens <- c(
    "splash-overlay" = 1,
    "app-intro" = 2,
    "app-main" = 3,
    "app-results" = 10
  )
  get_screen_next <- function(x) names(app_screens)[which(names(app_screens) == x) + 1L]
  get_screen_prev <- function(x) names(app_screens)[which(names(app_screens) == x) - 1L]

  question <- reactive({
    if (app_data$iter > length(question_ids)) return(NULL)
    questions %>%
      filter(id == question_ids[[app_data$iter]])
  })

  card_swipe <- callModule(shinyswipr, "card_swipe_ui")
  card_swipe_test <- callModule(shinyswipr, "test_card_swipe_ui")

  question_ids <- arrange(questions, order) %>% pull(id)

  output$question_text <- renderText({
    if (!app_data$complete) {
      question()$`Question Text`
    } else {
      "No more questions at this time. Hang on while we crunch the numbers..."
    }
  })
  output$question_category <- renderText({
      if (!app_data$complete) question()$Category else "Thank You!"
  })
  output$question_topic <- renderText({
      if (!app_data$complete) question()$Topic else "All Done!"
  })
  output$results_table <- renderDataTable({
    app_data$results
  })
  output$question_story <- renderUI({
    if (!app_data$complete) {
      q_story <- question()$Story
      if (is.na(q_story)) return(p("No story."))
      tagList(
        h1(app_data$male_name, "Experience"),
        q_story %>%
          strsplit("\\s*(\r\n){1,2}") %>%
          .[[1]] %>%
          purrr::map(~ tags$p(.))
      )
    }
  })
  output$question_story_link <- renderUI({
    if (app_data$complete) return(NULL)
    q_story <- question()$Story
    if (is.na(q_story)) return(NULL)
    app_data$male_name <- possessive_name(random_name())
    actionLink("app_main_show_story",
               paste("Read", app_data$male_name, "story..."))
  })
  output$results_plot <- renderPlot({
    req(app_data$complete)
    plot_swipe_results(questions, app_data$results, SWIPES_MEAN)
  })


  observe({
    # cat("iter:", app_data$iter, "\n")
    # cat("ques:", question()$`Question Text`, "\n")
    # print(app_data$results)
    # str(app_data)
  })

  # on main app card swipe
  observeEvent(card_swipe(), {
    if (app_data$complete) {
      # cat("\nNothing to do.")
      saveRDS(app_data$results, "results.rds")
      app_data$screen_next <- "app-results"
      return()
    }
    # save swipe event
    app_data$results <- bind_rows(
      data_frame(
        question_id = question()$id,
        swipe = card_swipe()
      ),
      app_data$results
    )

    # update app_data
    Sys.sleep(0.5) # wait for animation to complete
    app_data$iter <- app_data$iter + 1L
    next_q <- question()
    if (is.null(next_q)) app_data$complete <- TRUE
  })

  observeEvent(input$splash_next_screen, {
    app_data$screen_next <- get_screen_next("splash-overlay")
  })

  observeEvent(input$toggle_splash, {
    if (!app_data$screen_active == "splash-overlay") {
      app_data$screen_next <- "splash-overlay"
    } else {
      app_data$screen_next <- app_data$screen_prev
    }
  })

  observeEvent(input$back, {
    if (!is.null(app_data$screen_prev)) app_data$screen_next <- app_data$screen_prev
  })
  observeEvent(input$jump_results, {
    last_results_file <- "results.rds"
    if (!file.exists(last_results_file)) {
      cat("No results saved yet.")
      return()
    }
    app_data$results <- readRDS(last_results_file)
    app_data$complete <- TRUE
    app_data$screen_next <- "app-results"
  })

  observeEvent(card_swipe_test(), {
    shinyjs::hide("test-card-swipe-container", anim = TRUE, animType = "fade", time = 1)
    Sys.sleep(1)
    shinyjs::show("test_swipe_success", anim = TRUE, animType = "fade")
  })

  observeEvent(input$app_intro_next, {
    app_data$screen_next <- get_screen_next("app-intro")
  })

  observeEvent(input$app_main_show_story, {
    shinyjs::removeClass("app-story", "fadeOutUp")
    shinyjs::addClass("app-story", "fadeInDown")
  })
  observeEvent(input$app_main_hide_story, {
    shinyjs::addClass("app-story", "fadeOutUp")
    shinyjs::removeClass("app-story", "fadeInDown")
  })
  observeEvent(app_data$complete, {
    if (!app_data$complete) return()
    app_data$screen_next <- "app-results"
  })

  observeEvent(app_data$screen_next, {
    if (is.null(app_data$screen_next)) return()
    # cat("\n", app_data$screen_active, "to", app_data$screen_next)
    if (app_screens[app_data$screen_active] < app_screens[app_data$screen_next]) {
      # Move forward: active out left, next in right
      shinyjs::removeClass(app_data$screen_active, "slideInLeft slideInRight")
      shinyjs::removeClass(app_data$screen_next, "slideOutLeft slideOutRight")
      shinyjs::addClass(app_data$screen_active, "slideOutLeft")
      shinyjs::addClass(app_data$screen_next, "slideInRight")
    } else {
      # Move backward: active out right, next in left
      shinyjs::removeClass(app_data$screen_active, "slideInLeft slideInRight")
      shinyjs::removeClass(app_data$screen_next, "slideOutLeft slideOutRight")
      shinyjs::addClass(app_data$screen_active, "slideOutRight")
      shinyjs::addClass(app_data$screen_next, "slideInLeft")
    }

    # Update screen state
    app_data$screen_prev   <- app_data$screen_active
    app_data$screen_active <- app_data$screen_next
    app_data$screen_next   <- NULL
  }, priority = -100)
}

shinyApp(ui = ui, server = server)