Merge pull request #45 from brentscott93/master

Add quickform() function

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: shinyforms
-Title: Description
+Title: Shiny extension for creating forms and surveys.
 Version: 0.0.0.9000
 Authors@R: person("Dean", "Attali", email = "[email protected]",
     role = c("aut", "cre"))
@@ -12,12 +12,17 @@ Imports:
     digest (>= 0.6.8),
     DT, 
     shiny (>= 0.13.2.9003),
-    shinyjs (>= 0.5.2)
+    shinyjs (>= 0.5.2),
+    googledrive, 
+    googlesheets4,
+    gmailr,
+    scales,
+    checkmate
 Suggests:
     knitr (>= 1.7),
     rmarkdown,
     testthat
 License: MIT + file LICENSE
 LazyData: true
 VignetteBuilder: knitr
-RoxygenNote: 6.1.1
+RoxygenNote: 7.1.1

NAMESPACE

@@ -4,3 +4,6 @@ export(STORAGE_TYPES)
 export(createFormApp)
 export(formServer)
 export(formUI)
+export(quickform)
+import(gmailr)
+import(shiny)

R/quickformHelpers.R

@@ -0,0 +1,146 @@
+#' Creates an AdminLTE like Box w/ colored top
+#' @noRd
+titleBox <- function(title, description){
+  div(class = 'quickform-title',
+      div(class = 'header', title),
+      div(class = "body", description)
+  )
+}
+
+#' Creates a plain AdminLTE like box
+#' @noRd
+questionBox <- function(question, ui){
+  div(class = 'quickform',
+      div(class = 'header', question),
+      div(class = "body", ui)
+  )
+}
+
+#' Generates UI for quickform
+#' @description This is the 'muscle' behind the UI building and taken from the UI of shinyforms. It takes a list(id, type, etc.) and decides what to make. Used with lapply in main quickform() function over questions arguments.
+#' @param question A list containing id, type, required, and (optionally) choices
+#' @noRd
+createQuestion <- function(question){
+
+  checkmate::assertString(question[["id"]])
+  checkmate::assertString(question[["type"]])
+  checkmate::assertString(question[["question"]])
+  #decide what widget to make
+  #all the shiny widgets have been renamed with wrappers to mimic the google form options
+  if(question[["type"]] == "numeric"){
+    input <- shiny::numericInput(question[["id"]], NULL, 0, width = "100%")
+  } else if(question[["type"]] == "checkbox"){
+    input <- shiny::checkboxInput(question[["id"]], question[["choices"]])
+  } else if(question[["type"]] == 'multiplechoice'){
+    input <- multipleChoice(question[["id"]], question[["choices"]])
+  } else if(question[["type"]] == 'dropdown'){
+    input < dropdown(question[["id"]], choices)
+  } else if(question[["type"]] == 'shortanswer'){
+    input <- shortAnswer(question[["id"]])
+  } else if(question[["type"]] == 'paragraph'){
+    input <- paragraph(question[["id"]])
+  } else {
+    stop('Not a valid question type')
+  }
+  #if questions is marked as required add a 'Required *' tag before widget
+  if(!is.null(question[["required"]])){
+    if (question[["required"]]){
+      ui <- shiny::tagList(shiny::h5('Required *', style = 'color:#fd0800;'), input)
+    } else {
+      ui <- input
+    }
+  } else {
+    ui <- input
+  }
+  #put everything in a box to make it look like a Google Form
+  #one widget to a box
+  questionBox(question[["question"]], ui)
+
+}
+
+#' Convenient wrappers for shiny widgets using the googleForm lingo
+#' @param id an inputId
+#' @param choices a list
+#' @noRd
+multipleChoice <- function(id, choices){
+  shiny::radioButtons(inputId = id,
+                      label = NULL,
+                      choices = choices,
+                      inline = FALSE)
+}
+
+
+#' Convenient wrappers for shiny widgets using the googleForm lingo
+#' @param id an inputId
+#' @param choices a list
+#' @noRd
+checkbox <- function(id, choices){
+  shiny::checkboxInput(inputId =  id,
+                       label = NULL,
+                       value= FALSE)
+}
+
+#' Convenient wrappers for shiny widgets using the googleForm lingo
+#' @param id an inputId
+#' @param choices a list
+#' @noRd
+dropdown <- function(id, choices){
+  shiny::selectInput(inputId = id,
+                     label = NULL,
+                     choices = choices,
+                     width = "100%")
+}
+
+
+#' Convenient wrappers for shiny widgets using the googleForm lingo
+#' @param id an inputId
+#' @noRd
+shortAnswer <- function(id){
+  shiny::textInput(inputId = id,
+                   label = NULL,
+                   width = "100%")
+
+}
+
+#' Convenient wrappers for shiny widgets using the googleForm lingo
+#' @param id an inputId
+#' @noRd
+paragraph <- function(id){
+  shiny::tagAppendAttributes(shiny::textAreaInput(inputId = id,
+                                                  label = NULL),
+                             style = 'width: 100%;')
+}
+
+#' Check for NULL required inputs
+#' @param question a question list 
+#' @param input the input reatcive list created by shiny
+#' @noRd
+checkRequired <- function(question, input){
+  if(!is.null(question[["required"]])){
+    if(question[["required"]]){
+      if(is.null(input[[question[["id"]]]])) showNotification('Please answer all required questions', type = 'error')
+      req(!is.null(input[[question[["id"]]]]))
+      if(nchar(input[[question[["id"]]]]) == 0) showNotification('Please answer all required questions', type = 'error')
+      req(nchar(input[[question[["id"]]]]) != 0)
+    }
+  }
+}
+
+#' Save data to google drive
+#' @description Currently not able to create a google sheet in a specific folder (see: https://github.com/tidyverse/googlesheets4/issues/111).
+#' Current approach is to make a sheet and move it. 
+#' Alternative would be to write to temp file locally and upload to specific folder.
+#' @noRd
+saveToDrive <- function(data, filename, folder){
+  googlesheets4::gs4_create(name = filename, sheets = data)
+  setProgress(0.75, detail = 'Please wait...')
+  googledrive::drive_mv(filename, path = file.path(folder, filename))
+}
+
+#' Save reactive values
+#' @noRd
+getUserInput <- function(question, input){
+  x <- data.frame(value = input[[question[["id"]]]])
+  names(x) <- question[["id"]]
+  x
+}

tests/quickform-test-app/app.R

@@ -0,0 +1,28 @@
+library(shinyforms)
+quickform(
+title = "My Survey",
+description = 'Describe your survey here',
+questions = list(
+  list(id = 'name',
+       type = 'shortanswer',
+       question = 'What is your name?'),
+  list(id = "age",
+       type = "numeric",
+       question = "Age (yrs)",
+       required = TRUE),
+  list(id = 'ethnicity',
+       type = "multiplechoice",
+       question = "Are you of Hispanic, Latino, or of Spanish origin?" ,
+       choices = list('No', 'Yes'),
+       required = TRUE),
+  list(id = 'shortanswer',
+       type = 'shortanswer',
+       question = 'One word to describe this app',
+       required = TRUE),
+  list(id = 'user_opinion',
+       type = 'paragraph',
+       question= 'Please provide any feedback')
+),
+gmail = FALSE,
+folder = 'test-output'
+)

tests/quickform-test-app/tests/shinytest.R

@@ -0,0 +1,4 @@
+library(shinytest)
+shinytest::testApp("./tests/quickform-test-app")
+
+

tests/quickform-test-app/tests/shinytest/quickform-test-launch-expected/001.json

@@ -0,0 +1,16 @@
+{
+  "input": {
+    "age": 50,
+    "ethnicity": "No",
+    "name": "",
+    "shortanswer": "",
+    "submit": 0,
+    "user_opinion": ""
+  },
+  "output": {
+    "returningUser": null
+  },
+  "export": {
+
+  }
+}

tests/quickform-test-app/tests/shinytest/quickform-test-launch.R

@@ -0,0 +1,5 @@
+app <- ShinyDriver$new("../../")
+app$snapshotInit("quickform-test-launch")
+
+app$setInputs(age = 50)
+app$snapshot()

tests/testthat/testQuickform.R

@@ -0,0 +1,51 @@
+library(testthat)
+library(shinyforms)
+
+#testing the quickform() function and helpers
+
+test_that("getUserInput() subsets a list and returns df", {
+  question <- list(id = "test_id")
+  input <- list(test_id = "test")
+  expect_equal(shinyforms:::getUserInput(question, input), data.frame(test_id = "test"))
+})
+
+test_that("quickform() errors when char. string not supplied to 'title' arg", {
+  expect_error(quickform(title = 1), "string")
+})
+
+test_that("quickform() errors when char. string not supplied to 'description' arg", {
+  expect_error(quickform(title = "1", description = 1), "string")
+})
+
+test_that("quickform() errors with invalid email", {
+  expect_error(quickform(questions = list(list(id = "id", type = "numeric")), gmail = "email"), "string")
+})
+
+test_that("quickform() errors when questions is not a list", {
+  expect_error(quickform(questions = "string", title = "", description = ""), "list")
+})
+
+test_that("quickform() errors when questions element is not a list", {
+  expect_error(quickform(title = "", 
+                         description = "",
+                         questions = list(
+                                       list(id = "id", type = "numeric"))),
+               "Must have length >= 3")
+})
+
+test_that("createQuestion() returns shiny.tag", {
+  expect_equal(class(shinyforms:::createQuestion(list(type="numeric", id = "id", question = "?"))), "shiny.tag")
+})
+
+test_that("createQuestion() errors with invalid type", {
+  expect_error(shinyforms:::createQuestion(list(id = "id", type = "invalid", question = "?")), 'Not a valid')
+})
+
+test_that("createQuestion() errors with no id", {
+  expect_error(shinyforms:::createQuestion(list(type = 'invalid')), "string")
+})
+
+test_that("createQuestion() errors with no question", {
+  expect_error(shinyforms:::createQuestion(list(type = 'numeric', id = 'id')), "string")
+})
+