|
|
|
|
|
|
|
|
# ---- APP PARAMETERS ---- |
|
|
# ---- APP PARAMETERS ---- |
|
|
APP_TITLE <- "App Title" |
|
|
APP_TITLE <- "App Title" |
|
|
HELP_TEXT <- "Some guidance text can go here" |
|
|
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")) |
|
|
top_male_names <- readRDS(here::here("t4c/data/top_male_names.rds")) |
|
|
random_name <- function() sample(top_male_names, 1) |
|
|
random_name <- function() sample(top_male_names, 1) |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
next_question <- question_itergen(questions) |
|
|
next_question <- question_itergen(questions) |
|
|
|
|
|
|
|
|
|
|
|
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(...) { |
|
|
phone_container <- function(...) { |
|
|
div( |
|
|
div( |
|
|
class = "phone-container", |
|
|
class = "phone-container", |
|
|
|
|
|
|
|
|
), |
|
|
), |
|
|
div( |
|
|
div( |
|
|
id = "app-intro", |
|
|
id = "app-intro", |
|
|
class = "app-main bg-white animated", |
|
|
|
|
|
|
|
|
class = "app-main bg-white animated slideOutRight", |
|
|
h1(APP_TITLE, class = "app-title text-white bg-moffitt-blue"), |
|
|
h1(APP_TITLE, class = "app-title text-white bg-moffitt-blue"), |
|
|
p(class = "help-text text-moffitt-grey", |
|
|
p(class = "help-text text-moffitt-grey", |
|
|
"Guidance about how to approach the questions goes here."), |
|
|
"Guidance about how to approach the questions goes here."), |
|
|
|
|
|
|
|
|
class = "app-story animated fadeOutUp", |
|
|
class = "app-story animated fadeOutUp", |
|
|
div(class = "close-button", actionLink("app_main_hide_story", NULL, icon("times", class = "fa-lg"))), |
|
|
div(class = "close-button", actionLink("app_main_hide_story", NULL, icon("times", class = "fa-lg"))), |
|
|
htmlOutput("question_story") |
|
|
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(), |
|
|
hr(), |
|
|
actionButton("toggle_splash", "Toggle Splash"), |
|
|
actionButton("toggle_splash", "Toggle Splash"), |
|
|
actionButton("back", "Back"), |
|
|
actionButton("back", "Back"), |
|
|
|
|
|
actionButton("jump_results", "Jump to Last Results"), |
|
|
h4("Answer History"), |
|
|
h4("Answer History"), |
|
|
dataTableOutput("results_table") |
|
|
dataTableOutput("results_table") |
|
|
) |
|
|
) |
|
|
|
|
|
|
|
|
app_screens <- c( |
|
|
app_screens <- c( |
|
|
"splash-overlay" = 1, |
|
|
"splash-overlay" = 1, |
|
|
"app-intro" = 2, |
|
|
"app-intro" = 2, |
|
|
"app-main" = 3 |
|
|
|
|
|
|
|
|
"app-main" = 3, |
|
|
|
|
|
"app-results" = 10 |
|
|
) |
|
|
) |
|
|
get_screen_next <- function(x) names(app_screens)[which(names(app_screens) == x) + 1L] |
|
|
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] |
|
|
get_screen_prev <- function(x) names(app_screens)[which(names(app_screens) == x) - 1L] |
|
|
|
|
|
|
|
|
actionLink("app_main_show_story", |
|
|
actionLink("app_main_show_story", |
|
|
paste("Read", app_data$male_name, "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({ |
|
|
observe({ |
|
|
|
|
|
|
|
|
# on main app card swipe |
|
|
# on main app card swipe |
|
|
observeEvent(card_swipe(), { |
|
|
observeEvent(card_swipe(), { |
|
|
if (app_data$complete) { |
|
|
if (app_data$complete) { |
|
|
cat("\nNothing to do.") |
|
|
|
|
|
|
|
|
# cat("\nNothing to do.") |
|
|
|
|
|
saveRDS(app_data$results, "results.rds") |
|
|
|
|
|
app_data$screen_next <- "app-results" |
|
|
return() |
|
|
return() |
|
|
} |
|
|
} |
|
|
# save swipe event |
|
|
# save swipe event |
|
|
|
|
|
|
|
|
observeEvent(input$back, { |
|
|
observeEvent(input$back, { |
|
|
if (!is.null(app_data$screen_prev)) app_data$screen_next <- app_data$screen_prev |
|
|
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(), { |
|
|
observeEvent(card_swipe_test(), { |
|
|
shinyjs::hide("test-card-swipe-container", anim = TRUE, animType = "fade", time = 1) |
|
|
shinyjs::hide("test-card-swipe-container", anim = TRUE, animType = "fade", time = 1) |
|
|
|
|
|
|
|
|
shinyjs::addClass("app-story", "fadeOutUp") |
|
|
shinyjs::addClass("app-story", "fadeOutUp") |
|
|
shinyjs::removeClass("app-story", "fadeInDown") |
|
|
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, { |
|
|
observeEvent(app_data$screen_next, { |
|
|
if (is.null(app_data$screen_next)) return() |
|
|
if (is.null(app_data$screen_next)) return() |
|
|
cat("\n", app_data$screen_active, "to", app_data$screen_next) |
|
|
|
|
|
|
|
|
# cat("\n", app_data$screen_active, "to", app_data$screen_next) |
|
|
if (app_screens[app_data$screen_active] < app_screens[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 |
|
|
# Move forward: active out left, next in right |
|
|
shinyjs::removeClass(app_data$screen_active, "slideInLeft slideInRight") |
|
|
shinyjs::removeClass(app_data$screen_active, "slideInLeft slideInRight") |