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)