R/utils_code_evaluation.R

In ArthurData/sqlnstructor: Learn and practice SQL

# [code evaluation] utils functions

#' sql_evaluation
#'
#' @param input shiny input
#' @param question_id id of the question block
#' @param expected_output expected dataframe to reach
#'
#' @importFrom shiny req isolate
#' @importFrom dplyr all_equal
#' @importFrom sqldf sqldf
sql_evaluation <- function(input, question_id, expected_output) {
  req(input[[sql_run_input_identifier(question_id)]])

  code <- isolate(input[[sql_code_input_identifier(question_id)]])

  if (isFALSE(is_empty(code))) {
    tryCatch({
      result <- isTRUE(
        all_equal(
          expected_output,
          eval(parse(text = paste0("sqldf('", code, "')")))
        )
      )
      prettify_result(result)
    }, error = function(cond) {
      div(
        class = "alert",
        alert_error_msg(cond$message)
      )
    })
  } else {
    div(
      class = "alert",
      alert_no_code()
    )
  }
}

#' r_evaluation
#'
#' @param input shiny input
#' @param question_id id of the question block
#' @param expected_output expected dataframe to reach
#'
#' @importFrom shiny req isolate
#' @importFrom dplyr all_equal
#' @importFrom shinyalert shinyalert
r_evaluation <- function(input, question_id, expected_output) {
  req(input[[r_run_input_identifier(question_id)]])

  code <- isolate(input[[r_code_input_identifier(question_id)]])

  if (isFALSE(is_empty(code))) {
    if (isFALSE(unwanted_functions(code))) {
      tryCatch({
        result <- isTRUE(
          all_equal(
            expected_output,
            eval(parse(text = code))
          )
        )
        prettify_result(result)
      }, error = function(cond) {
        if(isFALSE(special_functions(code))) {
          div(
            class = "alert",
            alert_error_msg(cond$message)
          )
        }
      })
    } else {
      div(
        class = "alert",
        alert_forbidden_fun()
      )
    }
  } else {
    div(
      class = "alert",
      alert_no_code()
    )
  }
}

#' prettify_result
#'
#' @param result result of a R or sql evaluation
#' @seealso sql_evaluation and r_evaluation
#'
#' @importFrom shiny HTML icon p
prettify_result <- function(result) {
  if (isTRUE(result)) {
    HTML(
      paste(
        icon("check-circle"),
        p(sample(success_sentences(), show_ratio(0.2)), style = "color:#2bc72b;")
      )
    )
  } else {
    HTML(
      paste(
        icon("times-circle"),
        p(sample(fail_sentences(), show_ratio(0.4)), style = "color:#e80606;")
      )
    )
  }
}

#' fail_sentences
#'
fail_sentences <- function() {
  sentences <- c(
    "try again !",
    "you look so close !",
    "stay strong",
    "keep it up !",
    "come on ! you can do it !",
    "never give up",
    "don't give up",
    "you can do it",
    "keep pushing",
    "Hang in there",
    "so close !",
    "it's up to you to continue !"
  )
  default_sentence <- rep("not exactly the expected output", length(sentences)*2)
  return(c(sentences, default_sentence))
}

#' success_sentences
#'
success_sentences <- function() {
  sentences <- c(
    "great !",
    "the sky is your limit !",
    "reach the stars",
    "queries seems to have no secrets for you !",
    "there you go !",
    "you do it !"
  )
  default_sentence <-  rep("good job !", length(sentences)*2)
  return(c(sentences, default_sentence))
}

#' show_ratio
#'
#' @param ratio a ratio to print a success or fail message
show_ratio <- function(ratio) {
  total <- 100

  if (is.numeric(ratio)) {
    if (ratio >= 0 & ratio <= 1) {
      v1 <- rep(1, ratio*100)
      v0 <- rep(0, total-length(v1))
      v <- c(v1, v0)
      sample(v, 1)
    } else {
      stop("Error with ratio : between 0 and 1")
    }
  } else {
    stop("Error with ratio : numeric input between 0 and 1")
  }
}

#' unwanted_functions
#' test if code contains unwanted functions
#'
#' @param input a string code
unwanted_functions <- function(input) {
  funs <- c('q()', 'quit()')
  any(unlist(lapply(funs, grepl, x = input, fixed = TRUE)))
}

#' special_functions
#' test if code contains special functions
#'
#' @param input a string code
special_functions <- function(input) {
  funs <- c('ilovesqlnstructor()')
  any(unlist(lapply(funs, grepl, x = input, fixed = TRUE)))
}

#' is_empty
#' test if code is emty
#'
#' @param input a string code
is_empty <- function(input) {
  nchar(trimws(input)) == 0
}