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)