R/shiny_rtutor.r

In skranz/RTutor2: Complete rewrite of RTutor internals combined with armd

examples.show.shiny.ps = function() {
  library(restorepoint)
  set.restore.point.options(display.restore.point=TRUE)
  #options(shiny.error=browser)
  library(RTutor)
  setwd("D:/libraries/RTutor/examples")
  ps.name = "Example"
  show.ps(ps.name, launch.browser=TRUE, import.rmd=TRUE)

  show.shiny.ps(ps.name, user.name="Seb", load.sav=FALSE, sample.solution=FALSE, import.rmd=TRUE, catch.errors=FALSE)

  show.shiny.ps(ps.name, user.name="Seb", load.sav=TRUE)
  show.shiny.ps(ps.name, launch.browser=TRUE)

  windows(title="Plots")

  setwd("D:/libraries/RTutor/examples")
  ps.name = "The Impact of Shrouded Fees 3"
  show.shiny.ps(ps.name, load.sav=FALSE, launch.browser=TRUE, sample.solution=TRUE, run.solved=TRUE)

  show.shiny.ps(ps.name, launch.browser=TRUE)

  options(shiny.error=traceback)
  show.shiny.ps(ps.name)
}



#' Run a problem set in the webbroser (or in the viewer pane).
#'
#' ... contains parameters specified in init.shiny.ps. They are explained here.
#'
#' @param load.sav shall the last saved be loaded?
#' @param sample.solution shall the sample solution be shown
#' @param run.solved if sample.solution or load.sav shall the correct chunks be automatically run when the problem set is loaded? (Starting the problem set then may take quite a while)
#' @param import.rmd shall the solution be imported from the rmd file specificed in the argument rmd.file
#' @param lauch.browser if TRUE (default) show the problem set in the browser. Otherwise it is shown in the RStudio viewer pane
#' @param catch.errors by default TRUE only set FALSE for debugging purposes in order to get a more informative traceback()
#' @param offline (FALSE or TRUE) Do you have no internet connection. By default it is checked whether RTutor can connect to the MathJax server. If you have no internet connection, you cannot render mathematic formulas. If RTutor wrongly thinks you have an internet connection, while you don't, your chunks may not show at all. If you encounter this problem, set manually offline=TRUE.
#' @param is.solved DEPRECEATED
#' @param html.data.frame shall data.frames and matrices be printed as html table if a chunk is checked? (Default=TRUE)
#' @param table.max.rows the maximum number of rows that is shown if a data.frame is printed as html.table
#' @param round.digits the number of digits that printed data.frames shall be rounded to
show.ps = function(ps.name, user.name="Seb", sav.file=NULL, load.sav = !is.null(sav.file), sample.solution=FALSE, run.solved=load.sav, import.rmd=FALSE, rmd.file = paste0(ps.name,"_",user.name,"_export.rmd"), launch.browser=TRUE, catch.errors = TRUE, dir=getwd(), rps.dir=dir, offline=!can.connect.to.MathJax(), left.margin=2, right.margin=2, is.solved, make.web.app=FALSE, make.session.ps=make.web.app, save.nothing=FALSE, show.solution.btn = TRUE, show.data.exp=TRUE, disable.graphics.dev=TRUE, clear.user=FALSE, check.whitelist=!is.null(wl), wl=NULL, verbose=FALSE, html.data.frame=TRUE,table.max.rows=25, round.digits=8, signif.digits=8, knit.print.opts=make.knit.print.opts(html.data.frame=html.data.frame,table.max.rows=table.max.rows, round.digits=round.digits, signif.digits=signif.digits), precomp=FALSE, noeval=FALSE, need.login=FALSE, login.dir = paste0(dir,"/login"), show.points=TRUE,  ...) {

  cat("\nInitialize problem set, this may take a while...")
  app = eventsApp(verbose = verbose)

  #browser()
  ps = init.shiny.ps(
    ps.name=ps.name, user.name=user.name,sav.file=sav.file,
    load.sav=load.sav, sample.solution=sample.solution,
    run.solved = run.solved,import.rmd=import.rmd,
    rmd.file=rmd.file,
    dir=dir, rps.dir=rps.dir, save.nothing=save.nothing,
    show.solution.btn = show.solution.btn, show.data.exp=show.data.exp,
    clear.user=clear.user,
    check.whitelist=check.whitelist, wl=wl,
    precomp=precomp, noeval=noeval, ...
  )
  
  ps$show.points = show.points
  ps$need.login = need.login
  ps$login.dir = login.dir
  
  ps$catch.errors = catch.errors
  ps$offline=offline
  ps$left.margin = left.margin
  ps$right.margin = right.margin

  # Replace knit.print.funs in globalenv
  knit.print.funs = make.knit.print.funs(knit.print.opts)
  old.knit.print.funs = replace.fields(dest=globalenv(), source=knit.print.funs)
  # restore old functions on exit
  if (!make.web.app)
    on.exit(replace.fields(dest=globalenv(), source=old.knit.print.funs), add=TRUE)

  restore.point("show.shiny.ps")

  n = NROW(ps$cdt)


  ps$view.in.container = FALSE
  ui = make.rtutor.ui()
  
  ex.inds = 1:NROW(ps$edt)
  #ex.inds = 1:2
  for (ex.ind in ex.inds)
    show.ex.ui(ex.ind)

  for (chunk.ind in 1:n) {
    make.chunk.handlers(chunk.ind=chunk.ind)
  }
  make.load.save.handlers()

  txt = as.character(ui)
  setAppUI(ui, app)

  if (make.session.ps) {
    app$initHandler = function(session, input, output,app,...) {
      # make local copy of ps
      ops = get.ps(TRUE)
      ops$running.web.app = TRUE
      ps = copy.ps.for.session(ops)

      app$ps = ps
      ps$session = session
      ps$input = input
      ps$output = output
    }
  } else {
    app$initHandler = function(session, input, output,...) {
      ps = get.ps(TRUE)
      ps$running.web.app = TRUE
      ps$session = session
      ps$input = input
      ps$output = output
    }
  }

  if (make.web.app) {
    return(app)
  }

  if (!isTRUE(launch.browser))
    launch.browser = rstudioapi::viewer


  if (disable.graphics.dev) {
    try(png("NUL"),silent=TRUE)
    on.exit(try(dev.off(),silent=TRUE), add=TRUE)
  }

  
  runEventsApp(app=app,ui=ui,launch.browser=launch.browser, quiet=FALSE)

}

show.shiny.ps = show.ps

init.shiny.ps = function(ps.name,dir=getwd(), user.name="Seb",  sav.file=NULL, load.sav = !is.null(sav.file), ex.inds =NULL, sample.solution=FALSE, run.solved=load.sav, import.rmd=FALSE, rmd.file = paste0(ps.name,"_",user.name,"_export.rmd"), rps.dir=dir, ups.dir=dir, save.nothing=FALSE, show.solution.btn=TRUE, show.data.exp=TRUE, clear.user = FALSE, check.whitelist=!is.null(wl), wl=NULL, precomp=FALSE, noeval=FALSE, replace.sol=precomp, preknit=FALSE, ups.save = default.ups.save(), show.load.save.panel=FALSE, show.export.panel=TRUE, show.save.btn=FALSE,log.file = paste0(dir,"/",ps.name,".log"), ...) {
  restore.point("init.shiny.ps")
  setwd(dir)

  ps = init.ps(ps.name,user.name, dir=dir, rps.dir=rps.dir, ups.dir=ups.dir, save.nothing=save.nothing, check.whitelist=check.whitelist, wl=wl, precomp=precomp, noeval=noeval, replace.sol=replace.sol, preknit=preknit, ups.save=ups.save, log.file=log.file)

  if (clear.user) {
    ps$ups = init.ups(user.name = user.name, ps=ps)    
  }

  ps$show.load.save.panel=show.load.save.panel
  ps$show.export.panel=show.export.panel
  ps$show.save.btn = show.save.btn
  
  ps$is.shiny = TRUE
  ps$show.solution.btn = show.solution.btn
  ps$show.data.exp = show.data.exp

  ps$shiny.ex.inds = ex.inds
  ps$shiny.dt = ps$rps$shiny.dt
  ps$chunk.ind = 0
  #ps$shiny.dt$code

  n = NROW(ps$cdt)
  ps$button.counter = list()
  ps$cdt$nali = replicate(n, list(), simplify=FALSE)
  ps$cdt$ui = replicate(n, list(), simplify=FALSE)

  ps$cdt$has.output.observer = rep(FALSE,n)
  ps$cdt$has.input.observer = rep(FALSE,n)
  ps$cdt$has.ui.renderer = rep(FALSE,n)
  ps$cdt$server = replicate(n, expression(), simplify=FALSE)

  for (chunk.ind in ps$cdt$chunk.ps.ind) {
    id = paste0("r.chunk_",chunk.ind,".ui.mode")
    ps[[id]] = reactiveValues(counter=0)
    # r.chunk.ui.mode = reactiveValues(counter=0)
  }


  if (sample.solution & !ps$rps$has.sol) {
    warning("I cannot show the sample solution, since the sample solution was not made available for the problem set.")
    sample.solution = FALSE
  }

  # init widgets for shiny
  for (wid in ps$rps$widgets) {
    Widget = ps$rps$Widgets[[wid$rta$type]]
    Widget$shiny.init.handlers.fun(wid=wid,ps=ps)
  }

  ups.init.shiny.ps(ps=ps, ups=ps$ups, sample.solution=sample.solution, ups.save=ups.save)  
  
  show.shiny.awards()
  
  changeHandler("exTabsetPanel",rtutor.ex.tab.change)

  set.ps(ps)
}

rtutor.ex.tab.change = function(value,...) {
  if (identical(value,"statsPanel")) {
    rtutor.update.stats.panel()
  }
}


observe.nextExBtns = function(session, ps=get.ps()) {
  restore.point("observe.nextExBtns")
  cdt = ps$cdt
  ex.inds = setdiff(unique(cdt$ex.ind),0)
  if (!is.null(ps$shiny.ex.inds))
    ex.inds = intersect(ex.inds, ps$shiny.ex.inds)


  ex.ind = 1
  for (ex.ind in setdiff(ex.inds,max(ex.inds))) {
    btn = paste0(paste0("nextExBtn", ex.ind))
    observe({
      #cat("observe ", btn)
      if (has.counter.increased(btn, session$input[[btn]])) {
        #cat("Go to exercise ",paste0("exPanel",ex.ind+1),"...")
        updateTabsetPanel(session, inputId="exTabsetPanel", selected = paste0("exPanel",ex.ind+1))
      }
    })
  }
}


rtutor.eval.to.string = function(code, envir=parent.frame(), convert=TRUE, check.whitelist=isTRUE(ps$check.whitelist), ps=get.ps()) {
  restore.point("rtutor.eval.to.string")
  txt = sep.lines(code)
  ok = FALSE

  all.str = tryCatch({
      expr.li <- parse.text.with.source(txt)
      ok <- TRUE
    },
    error = function(e) {
      as.character(e)
    }
  )

  if (ok & check.whitelist) {
    res = rtutor.check.whitelist(expr.li,ps=ps)
    ok = res$ok
    if (!ok) {
      all.str = res$msg
    }
  }

  if (ok) {
    if (isTRUE(ps$use.secure.eval)) {
      all.str = try(rtutor.eval.secure(inner.rtutor.eval.to.string(expr.li, envir=envir), ps=ps))
      if (is(all.str,"try-error"))
        all.str = as.character(all.str)
    } else {
      all.str = inner.rtutor.eval.to.string(expr.li, envir=envir)
    }
  }

  # convert special characters that cause JSON errors when shown in
  # HTML output or in ace console
  if (convert) {
    all.str = iconv(all.str, "LATIN2", "UTF-8")
    all.str = gsub("[\u0091\u0092]","'",all.str)

  }
  all.str
}

# this function performs evals and may be called inside eval.secure
inner.rtutor.eval.to.string = function(expr.li, envir) {
  all.str = NULL
  add = function(...) {
    str = paste0(..., collapse="\n")
    all.str <<- paste0(all.str,str, sep="\n")
  }
  i = 1
  for (i in seq_along(expr.li$expr)) {
    source = "Source was not parsed..."

    add("> ",paste0(expr.li$source[[i]], collapse="\n+ "))
    out = tryCatch(capture.output(eval(expr.li$expr[[i]], envir=envir)),
                   error = function(e) {
                     adapt.console.err.message(as.character(e))
                   })
    if (length(out)>0) {
      add(out)
    }
  }
  all.str    
}


eval.in.ace.console = function(code,envir=parent.frame(), consoleId,session=app$session, app=getApp()) {
  restore.point("eval.in.ace.console")
  if (is.null(code)) code = ""
  out = rtutor.eval.to.string(code,envir, convert=TRUE)

  #iconv(out,"UTF-8", "LATIN2")
  if (length(out)==0)
    out = ""

  # remove special characters that cause errors in ACE console
  tryCatch(updateAceEditor(session, consoleId, value=out,mode="r"),
           error = function(e) {message(e)}
  )
  #cat("\n ace console was successfuly updated!")
}


eval.in.console = function(code, envir=parent.frame()) {
  restore.point("eval.in.console")
  out = rtutor.eval.to.string(code,envir)
  cat(out)
}

is.last.chunk.of.ex = function(chunk.ind, ps=get.ps()) {
  ex.ind = ps$cdt$ex.ind[chunk.ind]
  chunk.ind == max(which(ps$cdt$ex.ind==ex.ind))
}

rerun.solved.chunks = function(ps = get.ps()) {
  inds = which(ps$cdt$is.solved)
  ok = TRUE
  for (chunk.ind in inds) {
    #cat("\n rerun chunk", chunk.ind)
    ps$chunk.ind = chunk.ind
    ps$task.env = make.chunk.task.env(chunk.ind, ps)
    if (is.null(ps$task.env)) {
      stop(ps$failure.message)
    }
    ps$cdt$task.env[[chunk.ind]] <- ps$task.env
    code = ps$cdt$stud.code[[chunk.ind]]

    if (!is.false(ps$catch.errors)) {
      ok = tryCatch({
        out <- rtutor.eval.to.string(code,ps$task.env)
        TRUE
      }, error = function(e) {
        message(as.character(e))
        FALSE
      })
    } else {
      out <- rtutor.eval.to.string(code,ps$task.env)
    }
    if (!ok)
      break
    if (is.last.chunk.of.ex(chunk.ind)) {
      ex.ind = ps$cdt$ex.ind[chunk.ind]
      ps$edt$ex.final.env[[ex.ind]] = copy.task.env(ps$task.env)
    }
  }
  # Could not rerun a chunk that was supposed to be solved
  # flag all later chunks as not solved
  if (!ok) {
    inds = which((1:NROW(ps$cdt$is.solved))>=chunk.ind)
    ps$cdt$is.solved[inds] = FALSE
  }
}


chunk.opt.list.to.string = function(li, add.comma=!TRUE) {
  if (length(li)==0)
    return("")
  is.char = sapply(li, is.character)
  quotes = ifelse(is.char,"'","")
  str = paste0(names(li),"=",quotes,li,quotes, collapse=", ")
  if (add.comma)
    str = paste0(", ", str)
  str
}

# Use local version of MathJax so that problem sets really run offline
mathJaxRTutor <- function(html, offline=ps$offline, ps=get.ps()) {
  restore.point("mathJaxRTutor")

  if (offline)
    return(html)

  #path =  paste0(system.file('www', package='RTutor'),"/MathJax")
  #if (!file.exists(path))
  path <- '//cdn.mathjax.org/mathjax/latest'

  command = paste0(path, '/MathJax.js?config=TeX-AMS-MML_HTMLorMML')
  #path <- 'https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML'

  tagList(
  tags$head(
  singleton(tags$script(src = command, type = 'text/javascript'))
  ),
  html,
  tags$script(HTML('MathJax.Hub.Queue(["Typeset", MathJax.Hub]);'))
  )
}

can.connect.to.MathJax = function() {
  library(RCurl)
  url.exists("http://cdn.mathjax.org/mathjax/latest/MathJax.js")
 # url.exists("http://www.mathjax.org/")
}