R/ppaGForm.R

In kent-orr/ppaGForm:

# ppaGForm
#
# Some useful keyboard shortcuts for package authoring:
#
#   Install Package:           'Ctrl + Shift + B'
#   Check Package:             'Ctrl + Shift + E'
#   Test Package:              'Ctrl + Shift + T'

library(dplyr)
library(shiny)
library(shinyWidgets)

# ------------------------------------------------------ Tools and Helpers -----

#' Remove special characters from html and other dirty data.
#'
#' @param htmlString A string to remove characters from. Most commonly an html string.
#'
#' @return
#' @export
#'
#' @examples
clean_html <- function(htmlString) {
  return(gsub("<.*?>", "", htmlString))
}

# Goglesheets4 and Shiny Integration

#' Shortcut for reading a google sheet. Most often used for a Questions / Responses format
#' 
#' @param url URL of the google sheet you want to call
#' @param sheet_ sheet you are calling
#' @param name_ name to be assigned the returned dataframe. 'g_' will prepend the string given here
#'
#' @return
#' @export
#'
#' @examples
pawpaw_sheet <- function(url, sheet_, name_ = questions) {
  data <- dplyr::mutate(googlesheets4::read_sheet(ss = url, sheet = sheet_), responses = base::as.character(responses))
  
  assign(paste0('g_', name_), data, envir = .GlobalEnv)
}

#' A wrapper to append responses to a google sheet. 
#'
#' @param data data that will be appended. A dataframe or other structured argument. Variable names will not be included.
#' @param url URL of the google sheet you want to append
#' @param sheet_ specific sheet you are appending to
#'
#' @return
#' @export
#'
#' @examples
pawpaw_sheet_append <- function(data, url, sheet_) {
  googlesheets4::sheet_append(ss = url, data = data, sheet = sheet_)
}

## -------------------------------------------------- question development -----


#' Build beginning html Form tag
#'
#' @param action what action the form should take. Often a URL
#' @param method POST or GET
#'
#' @return
#' @export
#'
#' @examples
form_build <- function(action, method="POST") {
  cat(
    paste0(
      "<form action='", action, "' method='", method, "' >"
    )
  )
}


#' Render a section of form questions from a dataframe for Shiny.
#'
#' @param data the data to be used. Most often a spreadsheet with sections, id, labels, questions, and responses
#' @param section_ the section to be processed into shiny inputs
#' @param likert_default if using the 'slider' or likert scale option, what default is selected?
#'
#' @return
#' @export
#'
#' @examples
section_shiny <- function(data = g_questions, section_, likert_default = NULL) {
  
  dat <- data %>%
    dplyr::filter(section == section_)
  
  text_inputs <- function(label_) {
    dat <- dat %>%
      dplyr::filter(label == label_)
    
    if(dat$type == 'text') {
      shiny::textInput(label_, dat$question, placeholder = dat$responses)
    } else { 
      if(dat$type == 'longAnswer') {
        shiny::textAreaInput(label_, dat$question, placeholder = dat$responses, height = '150px')
      } else {
        if(dat$type == 'date') {
          shiny::dateInput(label_, dat$question, format = "mm/dd/yyyy")
        } else {
          if(dat$type == 'categorical') {
            shiny::radioButtons(label_, dat$question, choices = stringr::str_split(dat$responses, ", ", simplify = TRUE))
          } else {
            if(dat$type == 'checkbox') {
              shiny::checkboxInput(label_, dat$question, width = '100%') 
            } else {
              if(dat$type == 'multipleAnswer') {
                shiny::checkboxGroupInput(label_, dat$question, choices = stringr::str_split(dat$responses, ", ", simplify = TRUE))
              } else {
                if(dat$type == 'numeric') {
                  shiny::numericInput(label_, dat$question, value = dat$responses)
                } else {
                  if(dat$type == 'select') {
                    shiny::selectInput(label_, dat$question, choices = stringr::str_split(dat$responses, ", ", simplify = TRUE))
                  } else {
                    if(dat$type == 'slider') {
                      div(class='likert',
                          radioButtons(label_, dat$question,
                                       choices = stringr::str_split(dat$responses, ", ")[[1]],
                                       selected = likert_default,
                                       inline = TRUE)
                      )
                    } else {
                      if(dat$type == 'phone') {
                        shiny::textInput(label_, dat$question, placeholder = "555-555-5555")
                      } else {
                        if(dat$type == 'email') {
                          shiny::textInput(label_, dat$question, placeholder = "janeDoe@gmail.com")
                        }
                      }
                    }
                  }
                }
              }
            }
          }
        }
      }
    }
  }
  
  lapply(dat$label, text_inputs)
}

# form html builders

#' Render a section of form questions from a dataframe for HTML forms If using a markdown document, need to set chunk results to results='asis'
#'
#' @param data the data to be used. Most often a spreadsheet with sections, id, labels, questions, and responses
#' @param section_ the section to be processed into shiny inputs
#' @param css_margin = css applied to div of class 'type' which defaults to a top and bottom margin of 1pc, but can be anything.
#'
#' @return
#' @export
#'
#' @examples
section_html <- function(data = g_questions, section_, css_margin = "margin:1pc 0 1pc 0;") {
  
  dat <- data %>%
    dplyr::filter(section == section_)
  
  text_inputs <- function(label_) {
    dat <- dat %>%
      dplyr::filter(label == label_)
    
    if(dat$type == 'text') {
      htmltools::div(class = dat$type, style=css_margin,
        htmltools::tags$label(dat$question),
        htmltools::tags$input(name=label_, value = dat$responses))
    } else { 
      if(dat$type == 'longAnswer') {
        htmltools::div(class = dat$type, style=paste0('display:flex;flex-direction:column;',css_margin),
          htmltools::tags$label(dat$question),
          htmltools::tags$textarea(name=label_, value = dat$responses))
      } else {
        if(dat$type == 'date') {
          htmltools::div(class = dat$type, style=css_margin,
            htmltools::tags$label(dat$question),
            htmltools::tags$input(type='date', name=label_, value = dat$responses))
        } else {
          if(dat$type == 'categorical') {
            htmltools::tags$div(class = dat$type, style=css_margin,
                                    htmltools::tags$label(dat$question), htmltools::tags$br(),
                                    lapply(stringr::str_split(dat$responses, ", ", simplify = TRUE),
                                           FUN = function(i) htmltools::tags$ul(style='padding-left:0;', (htmltools::tagList(
                                             htmltools::tags$li(style="list-style-type:none;margin:0;margin-left:5px;padding:0;display:flex;",
                                                                htmltools::tags$input(type='radio', id=i, value=i, name=label_),
                                                                htmltools::tags$label(style='display:flex;flex-direction:column;padding-left:5px;', i, 'for'=i))
                                           )
                                           )
                                    )
                )
            )
          } else {
            if(dat$type == 'checkbox') {
              htmltools::tags$div(class = dat$type, style=css_margin,
                                    htmltools::tags$label(dat$question), htmltools::tags$br(),
                                    lapply(stringr::str_split(dat$responses, ", ", simplify = TRUE),
                                           FUN = function(i) htmltools::tags$ul(style='padding-left:0;', (htmltools::tagList(
                                             htmltools::tags$li(style="list-style-type:none;margin:0;margin-left:5px;padding:0;display:flex;",
                                                                htmltools::tags$input(type='checkbox', id=i, value=i, name=label_),
                                                                htmltools::tags$label(style='display:flex;flex-direction:column;padding-left:5px;', i, 'for'=i))
                                           )
                                           )
                                    )
                )
              )
            } else {
              if(dat$type == 'multipleAnswer') {
                htmltools::tags$div(class = dat$type, style=css_margin,
                                    htmltools::tags$label(dat$question), htmltools::tags$br(),
                                    lapply(stringr::str_split(dat$responses, ", ", simplify = TRUE),
                                           FUN = function(i) htmltools::tags$ul(style='padding-left:0;', (htmltools::tagList(
                                             htmltools::tags$li(style="list-style-type:none;margin:0;margin-left:5px;padding:0;display:flex;",
                                                                htmltools::tags$input(type='checkbox', id=i, value=i, name=label_),
                                                                htmltools::tags$label(style='display:flex;flex-direction:column;padding-left:5px;', i, 'for'=i))
                                           )
                                           )
                                    )
                )
                )
              } else {
                if(dat$type == 'numeric') {
                  htmltools::tags$div(class = dat$type, style=css_margin,
                                      htmltools::tags$label(dat$question, 'for'=label_),
                                      htmltools::tags$input(type='number', id=label_, name=label_))
                } else {
                  if(dat$type == 'select') {
                    htmltools::div(
                      htmltools::tags$label(dat$question, style=css_margin,
                                            htmltools::tags$select(name=label_,
                                                                   invisible(lapply(stringr::str_split(dat$responses, ", ", simplify = TRUE), function(x) tags$option(value=x, x)))
                                            )
                      )
                    )
                  } else {
                    if(dat$type == 'slider') {
                      htmltools::tags$div(class = dat$type, style=css_margin,
                                          htmltools::tags$label('for'=label_, dat$question),
                                          htmltools::tags$input(type='range', id=label_, name=label_, 
                                                                min = min(stringr::str_split(dat$responses, ", ", simplify = TRUE)),
                                                                max = max(stringr::str_split(dat$responses, ", ", simplify = TRUE))
                                                                )
                                          )
                    } else {
                      if(dat$type == 'likert') {
                        htmltools::tags$div(class = paste0(dat$type,"-wrap"), style=css_margin,
                                            htmltools::tags$label(class='q_label', dat$question),
                                            htmltools::tags$ul(class='likert', style='display:flex;justify-content:space-between;list-style-type:none;padding:0;',
                                                               lapply(str_split(dat$responses, ", ", simplify = T), 
                                                                      function(x) htmltools::tags$li(style='display:flex;flex-flow:column;text-align:center;justify-content:center;',
                                                                        htmltools::tags$input(style='margin:auto;', type='radio', name=label_, value = x),
                                                                        htmltools::tags$label(x)
                                                                        )
                                                                      )
                                                               )
                                            )
                      } else {
                        if(dat$type == 'phone') {
                          htmltools::tags$div(class = dat$type, style=css_margin,
                                              htmltools::tags$label(dat$question, 'for'=label_),
                                              htmltools::tags$input(type='tel', id=label_, name=label_, pattern="[0-9]{3}-[0-9]{3}-[0-9]{4}", placeholder="555-555-1234"),
                                              htmltools::tags$small("format: 555-555-1234"))
                        } else {
                          if (dat$type == 'email') {
                            htmltools::tags$div(class = dat$type, style=css_margin,
                                                htmltools::tags$label(dat$question, 'for'=label_),
                                                htmltools::tags$input(type='email', id=label_, name=label_))
                          }
                        }
                      }
                    }
                  }
                }
              }
            }
          }
        }
      }
    }
  }
  
  section_dat <- lapply(dat$label, text_inputs)

  for (i in 1:length(section_dat)) {
    print(section_dat[[i]])
  }
}


#' Form submit button and an end tag
#'
#' @return
#' @export
#'
#' @examples
form_end <- function() {
  cat("<button type='submit'>Send</button> </form>")
}