t4c/t4c/app.R

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

# ---- 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("t4c/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 = 24, 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"))
)

ui <- fixedPage(
  includeCSS("devices.min.css"),
  includeCSS("t4c.css"),
  includeCSS("moffitt-colors.css"),
  includeCSS("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"),

  # h1("A Good Name and Logo"),
  # p("This is a simple demo app..."),
  # hr(),
  p(),
  phone_container(
    div(
      class = "overlay bg-moffitt-grey splash animated", id = "splash-overlay",
      div(
        class = "splash-body",
        h1("Welcome!"),
        p("Talking about cancer treatment options is hard, but we're here to help."),
        actionButton("splash_next_screen", "Get Started", class = "btn-bottom-right btn-primary")
      )
    ),
    div(
      id = "app-intro",
      class = "app-main bg-white animated slideOutRight",
      h1(APP_TITLE, class = "app-title text-white bg-moffitt-blue"),
      p(class = "help-text text-moffitt-grey",
        "Guidance about how to approach the questions goes here."),
      div(
        id = "test-card-swipe-container",
        style = "width: 100%; max-height: 275px; position: relative; height: 100%;",
        shinyswiprUI(
          "test_card_swipe_ui",
          div(class = "swiperCard-header",
              h4(class = "card-title text-white bg-moffitt-light-blue",
                 "Try It Now"
              )
          ),
          div(class = "swiperCard-body",
              h4("An Example Question"),
              p("Something to think about. Swipe", strong("left"), "if you feel X.",
                "Swipe", strong("right"), "if you feel Y.")
          )
        ),
        swipe_help_row_div
      ),
      shinyjs::hidden(div(
        id = "test_swipe_success",
        style = "font-size: 1.5em; text-align: center; width: 100%; padding: 50px",
        p(icon("thumbs-o-up", class = "fa-3x text-moffitt-green"),
          br(),
          actionLink("app_intro_next", "Great, let's get started!")
        )
      ))
    ),
    div(
        id = "app-main",
        class = "app-main animated",
        h1(APP_TITLE, class = "app-title text-white bg-moffitt-blue"),
        p(HELP_TEXT, class = "help-text text-moffitt-grey"),
        shinyswiprUI(
            "card_swipe_ui",
            div(class = "swiperCard-header",
                h4(class = "card-title text-white bg-moffitt-light-blue",
                   textOutput("question_category")
                )
            ),
            div(class = "swiperCard-body",
                h4(textOutput("question_topic")),
                p(textOutput("question_text")),
                uiOutput("question_story_link")
            )
        ),
        swipe_help_row_div
    ),
    div(
      id = "app-story",
      class = "app-story animated fadeOutUp",
      div(class = "close-button", actionLink("app_main_hide_story", NULL, icon("times", class = "fa-lg"))),
      htmlOutput("question_story")
    ),
    div(
      id = "app-results",
      class = "app-main app-results bg-white animated slideOutRight",
      h1(APP_TITLE, class = "app-title text-white bg-moffitt-blue"),
      div(class = "app-results-body",
          h2("Results", class = "help-text text-moffitt-grey"),
          plotOutput("results_plot", height = "250px")
      )
    )
  ),
  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 <- here::here("t4c", "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)