app.R

#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

library(shiny)
library(shinyglide)
library(shinyWidgets)
library(readxl)
library(httr)

##########################
# data
##########################

GET("https://github.com/zoidy/ModelDataRubric/raw/main/Descriptor-classifications-worksheet-v2.0.xlsx",
    write_disk("rubric.xlsx", overwrite = TRUE))
data <- read_excel("rubric.xlsx")
file.remove("rubric.xlsx")

# Generate a list where each item is a list of row indices that belong to the same "category"
# as defined by the first column. The indices are in the same order as they appear in the 
# input sheet. (Assisted by Gemeni)
#
# Example:
#     row_indices_list[2] is a list with elements [4,5]
# This means that the second group of rows (grouped according to the value of the first column)
# are rows 4 and 5. In other words, rows 4 and 5 have the same value in the first column.
row_indices_list <- split(
  seq_len(nrow(data)), 
  factor(data$`Section Theme`, levels = unique(data$`Section Theme`))
)


##########################
# UI - variables and funcs
##########################
numqs <<- 0

controls <- tags$div(
    tags$div(class="my-control prev-screen"),
    tags$div(class="my-control next-screen")
)

css <- "
    .my-control {
      font-size: 0em;
    }

    .pretty { /* https://github.com/dreamRs/shinyWidgets/issues/478 */
          white-space: normal;
          margin-bottom: 5px;
    }
    .pretty .state label {
      line-height: 1.5em;
      margin-top: -4px;
    }
    .pretty .state label::after, .pretty .state label::before {
      top: -2px;
    }
    
    .link_button {
        -webkit-border-radius: 4px;
        -moz-border-radius: 4px;
        border-radius: 4px;
        border: solid 1px #20538D;
        text-shadow: 0 -1px 0 rgba(0, 0, 0, 0.4);
        -webkit-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.4), 0 1px 1px rgba(0, 0, 0, 0.2);
        -moz-box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.4), 0 1px 1px rgba(0, 0, 0, 0.2);
        box-shadow: inset 0 1px 0 rgba(255, 255, 255, 0.4), 0 1px 1px rgba(0, 0, 0, 0.2);
        background: #4479BA;
        color: #FFF;
        padding: 8px 12px;
        text-decoration: none;
    }
    
    max-width: 800px;
  "

build_header <- function(num, theme = TRUE, bigpicture = TRUE) {
    list(
        if (theme) h2("Theme:",data$`Section Theme`[num]) else span(),
        if (bigpicture) h3(data$`Big Picture Question`[num]) else span(),
        br()
    )
}

build_question <- function(num) {
    numqs <<- numqs + 1
    list(
        strong("Question",num),
        p(data$Descriptor[num]),
        p(em(data$`Descriptor definition`[num])),
        br(),
        prettyRadioButtons(
            inputId = paste0("Q",num),
            label = NULL,
            width = "100%",
            choices = build_question_listchoices(num)
        )
    )
}

build_question_listchoices <- function(num) {
    l <- setNames(
        c(if(is.na(data$`Class 1`[num])) {} else paste0("1:",data$`Suggested Weight                (If score > 1)`[num]),
          if(is.na(data$`Class 2`[num])) {} else paste0("2:",data$`Suggested Weight                (If score > 1)`[num]),
          if(is.na(data$`Class 3`[num])) {} else paste0("3:",data$`Suggested Weight                (If score > 1)`[num])),
        c(if(is.na(data$`Class 1`)[num]) {} else data$`Class 1`[num], 
          if(is.na(data$`Class 2`)[num]) {} else data$`Class 2`[num], 
          if(is.na(data$`Class 3`)[num]) {} else data$`Class 3`[num])
    )
    
}

build_nav <- function(first = FALSE, last = FALSE) {
    #avoid the built-in shinyglide buttons. They appear too far down
    #so build our own
    nav <- div(`data-glide-el`="controls")
    
    if(!first && !last) {
      first <- TRUE
      last <- TRUE
    }
    
    if(last)
      nav <- tagAppendChildren(nav,
              a(`data-glide-dir`="<", href="#", "Back", class="link_button"),
              span("  ")
             )
                        
    if(first)
      nav <- tagAppendChild(nav,
              a(`data-glide-dir`=">", href="#", "Next", class="link_button")
             )
    
    nav <- tagAppendChildren(p(br()),nav,br())
}

##########################
# UI - shiny
##########################
instructions_screen <- list(
  h1("Instructions"),
  p("The rubric is built to help researchers make decisions about what simulation output needs to be
          shared via a repository, i.e. made accessible and preserved a sufficient time to satisfy the
          requirements of publishers and funding agencies. Ultimately, these decisions are based on the
          goal of all community members (researchers, publishers, end users) to communicate knowledge
          in a sustainable way. Note this rubric is not meant to dictate what a researcher or research
          group keeps on their own local storage.
          The rubric is a list of simulation/experiment descriptors, organized into themes. To use the
          rubric, consider a specific simulation workflow and review all of the descriptors, selecting a
          Class (1, 2, or 3) that best fits your workflow for each descriptor. If you find that your workflow
          could be a Class 1 or 3 based on which descriptor you are looking at, you can separate the
          workflow into logical sections and then classify each section separately.
      "),
  p("See the ", a(href="https://modeldatarcn.github.io/rubrics-worksheets/Rubric-Instructions-and-Use-Cases.pdf","instructions"),
    "and", a(href="https://modeldatarcn.github.io","https://modeldatarcn.github.io"),
    "for more information"),
  p(a(href="https://github.com/zoidy/ModelDataRubric","Source code")),
  build_nav(first = T)
)

results_screen <- list(
  h1("Results"),
  h2("Your weighted score:",textOutput("s1", inline = T)),
  p(strong("Rubric Total Weighted Score < 48")),
  tags$ul(
    tags$li("Preserve few simulation workflow outputs"),
    tags$li("Preserve and provide access to simulation workflow configuration and code components"),
    tags$li("See Use Case 1"),
  ),
  br(),
  p(strong("Rubric Total Weighted Score between 48 and 72")),
  tags$ul(
    tags$li("Preserve selected simulation workflow outputs"),
    tags$li("Preserve and provide access to simulation workflow configuration and code components"),
    tags$li("See Use Case 2"),
  ),
  br(),
  p(strong("Rubric Total Weighted score > 72")),
  tags$ul(
    tags$li("Preserve the majority simulation workflow outputs"),
    tags$li("Preserve and provide access to simulation workflow configuration and code components"),
    tags$li("See Use Case 3"),
  ),
  br(),
  p(a(href="https://modeldatarcn.github.io/rubrics-worksheets/Rubric-Instructions-and-Use-Cases.pdf","Use cases reference")),
  build_nav(last = T)
)


screens <- list(instructions_screen)
for(i in seq(from=2, to=length(row_indices_list)+1, length.out=length(row_indices_list))){
  # build the questions screens from the data by taking the questions from the indices of the grouped rows
  screens[[i]] <- list(
       build_header(row_indices_list[[i-1]][1]),
       lapply(row_indices_list[[i-1]], build_question),
       build_nav()
     )
}
screens[[length(screens)+1]] <- results_screen

ui <- fluidPage(
    tags$head(
        tags$style(css)
    ),
    
    titlePanel("What About Model Data? Best Practices for Preservation and Replicability"),
    glide(
      next_label = icon("chevron-right", lib="glyphicon"),
      previous_label = icon("chevron-left", lib="glyphicon"),
      loading_label = icon("hourglass", lib="glyphicon"),
      swipe = TRUE,
      keyboard = FALSE, #keyboard nav changes the radio button selection
      custom_controls = controls,
      lapply(screens, screen)
    )
)


##########################
# Server
##########################
server <- function(input, output, session) {
    
    result <- reactiveVal(0)

    output$s1 <- renderText({
        c(result())
    })

    event_triggers <- reactive({
        #Listen to events from all question inputs
        #https://stackoverflow.com/a/41961038
        #https://community.rstudio.com/t/looping-through-shiny-inputs-by-name-using-get-not-working-why/24145/2
        l <- list()
        for(i in seq(numqs))
            l <- append(l, input[[paste0("Q",i)]])
        l
    })
    
    observeEvent(event_triggers(),{
        # Calculate the score on every event and update the reactive variable for display
        score <- 0
        if(numqs > 0) {
          for(i in seq(numqs)) {
              q_vals <- lapply(strsplit(input[[paste0("Q",i)]],":"), as.numeric)
              if(q_vals[[1]][1] == 1) {
                score <- score + q_vals[[1]][1]
              } else {
                score <- score + prod(q_vals[[1]])
              }
              print(paste(i,prod(q_vals[[1]])))
          }
        }
        print(paste("score:", score))
        result(score)
    })
}

# Run the application 
shinyApp(ui = ui, server = server)