R/knit_print.r

In skranz/RTutor: Interactive R problem sets with automatic testing of solutions and automatic hints

knit.to.html = function(..., fragment.only=NULL) {
  if (!is.null(fragment.only)) {
    if (utils::packageVersion("markdown")>="1.3") {
      knitr::knit2html(..., template=!fragment.only)
    } else {
      knitr::knit2html(..., fragment.only=fragment.only)
    }
  } else {
    knitr::knit2html(...)
  }
}



# We need now to explicitly call registerS3method
# see https://github.com/yihui/knitr/issues/1580
register.knit.print.functions = function(knit.print.opts) {
  for (opt in knit.print.opts) {
    if (!is.null(opt$fun)) {
      for (class in opt$classes) {
        registerS3method("knit_print", class, opt$fun)
      }
    }
  }
}


set.knit.print.opts = function(html.data.frame=TRUE,table.max.rows=25, table.max.cols=NULL, round.digits=8, signif.digits=8, show.col.tooltips = TRUE, print.data.frame.fun = NULL, print.matrix.fun=NULL, env=.GlobalEnv, opts=NULL, data.frame.theme = c("code","html","kable","grid","flextable")[1+html.data.frame],word.table.style="Table Simple 1",...) {
  restore.point("set.knit.print.opts")
  #cat(output)
  if (is.null(opts)) {
    #if (is(output,"try-error")) output="html"
    #if (is.null(output)) output = "html"
    opts = make.knit.print.opts(data.frame.theme=data.frame.theme, ,table.max.rows=table.max.rows, table.max.cols=table.max.cols, round.digits=round.digits, signif.digits=signif.digits, show.col.tooltips = FALSE, print.data.frame.fun = print.data.frame.fun, print.matrix.fun=print.matrix.fun, word.table.style=word.table.style)
  }
  register.knit.print.functions(opts)  
#  for (opt in opts) {
#    fun.names = paste0("knit_print.",opt$classes)
#    if (!is.null(opt$fun)) {
#      for (fun.name in fun.names)
#        env[[fun.name]] = opt$fun
#    }
#  }

}

make.knit.print.opts = function(html.data.frame=TRUE,table.max.rows=25, table.max.cols=NULL, round.digits=8, signif.digits=8, show.col.tooltips = TRUE, print.data.frame.fun = NULL, print.matrix.fun=NULL, data.frame.theme = c("code","html","kable","grid","flextable")[1+html.data.frame], word.table.style="Table Simple 1") {
  opts = list()
  restore.point("make.knit.print.opts")
  
  #attr(opts,"knit.params") = nlist(html.data.frame,table.max.rows, round.digits, signif.digits, show.col.tooltips)
  
  if (!is.null(print.data.frame.fun)) {
   opts[["data.frame"]] = list(
      fun= print.data.frame.fun,
      classes=c("data.frame")
    )
  } else {
    opts[["data.frame"]] = list(
      fun= function(x, options=NULL, ...) {
        restore.point("ndnfhdubfdbfbfbh")
        
        rtutor.knit_print.data.frame(x,table.max.rows=table.max.rows,table.max.cols=table.max.cols, round.digits=round.digits, signif.digits=signif.digits, show.col.tooltips=show.col.tooltips, options=options, data.frame.theme=data.frame.theme, word.table.style=word.table.style,...)  
      },
      classes=c("data.frame","tbl","tbl_df","grouped_df")
    )
  } 
  if (!is.null(print.matrix.fun)) {
    opts[["matrix"]] = list(
      fun= print.data.frame.fun,
      classes=c("matrix")
    )
  }
  opts
}

make.knit.print.funs = function(knit.print.opts, parent.env = globalenv()) {
  env = new.env(parent=parent.env)
  for (opt in knit.print.opts) {
    fun.names = paste0("knit_print.",opt$classes)
    if (!is.null(opt$fun)) {
      for (fun.name in fun.names)
        env[[fun.name]] = opt$fun
    }
  }
  as.list(env)
}

add.htmlwidget.as.shiny <- function(x,
   outputId=paste0("htmlwidget_output",sample.int(100000,1)),
   session = getDefaultReactiveDomain(), app=getApp()) 
{
  restore.point("add.htmlwidget.as.shiny")

  widget.name = class(x)[1]
  
  # output function for widget
  outputFun <- function(outputId, width = "100%", height = "400px",...) {
    htmlwidgets::shinyWidgetOutput(outputId, widget.name, width, height)
  }

  # add renderer that simply evaluates the htmlwidget x
  env = new.env(parent=globalenv())
  env$x = x
  
  renderer = htmlwidgets::shinyRenderWidget(quote(x), outputFunction=outputFun, env=env, quoted=TRUE)
  app$output[[outputId]] = renderer 
  if (!is.null(session))
    session$output[[outputId]] = renderer
  
  # create ui
  ui = outputFun(outputId)

  return(ui)
}

# overwrite knit_print for htmlwidget
rtutor.knit_print.htmlwidget = function(x,...) {
  restore.point("rtutor.knit_print.htmlwidget")
    
  ps = get.ps()
  chunk.ind = ps$chunk.ind
  outputId=paste0("chunk_htmlwidget_",ps$cdt$nali[[chunk.ind]]$name)

  ui = add.htmlwidget.as.shiny(x, outputId = outputId)
  ui = add.htmlwidget.as.shiny(x)
  #restore.point("ndjndhvbrubr")
  
  # knitr shall output ui
  knit_print.shiny.tag.list(ui)
}

rtutor.knit_print.shiny.tag.list = function (x, ...) 
{
  restore.point("rtutor.knit_print.shiny.tag.list")
  
  x <- htmltools:::tagify(x)
  output <- surroundSingletons(x)
  deps <- resolveDependencies(htmltool:::findDependencies(x))
    content <- htmltool:::takeHeads(output)
    head_content <- htmltool:::doRenderTags(tagList(content$head))
    meta <- if (length(head_content) > 1 || head_content != "") {
        list(structure(head_content, class = "shiny_head"))
    }
    meta <- c(meta, deps)
    knitr::asis_output(HTML(format(content$ui, indent = FALSE)), 
        meta = meta)
}

rtutor.knit_print.data.frame = function(x, table.max.rows=25, table.max.cols=NULL, round.digits=8, signif.digits=8, data.frame.theme=c("code","html","kable","grid","flextable")[1], show.col.tooltips=TRUE, col.tooltips=NULL, options=NULL,word.table.style="Table Simple 1", ...) {
  restore.point("rtutor.knit_print.data.frame")
  
  if (is.matrix(x))
    x = as.data.frame(x)
  
  # chunk options have precedent over passed arguments
  copy.non.null.fields(dest=environment(), source=options, fields=c("table.max.rows","table.max.cols", "round.digits","signif.digits","data.frame.theme","show.col.tooltips"))
  
  #col.tooltips = NULL
  if (show.col.tooltips & is.null(col.tooltips) & data.frame.theme=="html") {
    var.dt = get.ps()$rps$var.dt
    if (!is.null(var.dt)) {
      vars = colnames(x)
      col.tooltips = get.var.descr.dt(vars=vars, var.dt=var.dt)$descr
      col.tooltips = paste0(vars, ": ", col.tooltips)
      col.tooltips = sapply(col.tooltips,USE.NAMES = FALSE, function(str) {
        paste0(strwrap(str, width=30), collapse="\n")
      })
    }
  }
  
  adapt.data = FALSE
  missing.txt = NULL
  if (!is.null(table.max.rows)) {
    if (NROW(x)>table.max.rows) {
      adapt.data = TRUE
      missing.txt = paste0("... only ", table.max.rows, " of ", NROW(x), " rows")
    }
  }
  if (!is.null(table.max.cols)) {
    if (NCOL(x)>table.max.cols) {
      adapt.data = TRUE
      if (is.null(missing.txt)) {
        missing.txt = paste0("... only ", table.max.cols, " of ", NROW(x), " columns")
      }
      missing.txt = paste0(missing.txt, " and ", table.max.cols, " of ", NCOL(x), " columns")
    }
  }
  if (adapt.data) {
    missing.txt = paste0(missing.txt, " shown ...")
    x = max.size.df(x,table.max.rows, table.max.cols)
    if (data.frame.theme=="html") {
      h1 = RTutor:::html.table(x,round.digits=round.digits, signif.digits=signif.digits, col.tooltips=col.tooltips,...)
      html = c(h1, as.character(p(missing.txt)))
      return(asis_output(html))
    } else if (data.frame.theme == "word") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      txt = paste0('```{=openxml}\n',word.xml.table(dat),"\n```\n","\n\n",missing.txt,"")
      return(asis_output(txt))
    } else if (data.frame.theme=="kable") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      txt = c(knit_print(kable(dat)),"",missing.txt,"")
      return(asis_output(txt))
    } else if (data.frame.theme == "grid") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      library(gridExtra); library(grid)
      grid.draw(tableGrob(dat, rows=NULL))
      return(asis_output(missing.txt))
    } else if (data.frame.theme == "flextable") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      library(flextable)
      tab = regulartable(dat) %>% theme_zebra()
      txt = c(knit_print(tab),"\n\n",missing.txt,"")
      return(asis_output(txt))

    } else {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits) 
      txt = capture.output(print(dat))
      txt = c(paste0(txt,collapse="\n"),missing.txt)
      return(txt)
    }
  } else {
    if (data.frame.theme=="html") {
      html = RTutor:::html.table(x,round.digits=round.digits, signif.digits=signif.digits, col.tooltips=col.tooltips, ...)
      return(asis_output(html))
    } else if (data.frame.theme == "word") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      txt = paste0('```{=openxml}\n',word.xml.table(dat),"\n```\n")
      return(asis_output(txt))
    } else if (data.frame.theme == "kable") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      txt = c(knit_print(kable(dat)),"","")
      return(asis_output(txt))
    } else if (data.frame.theme == "grid") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      library(gridExtra); library(grid)
      grid.newpage()
      grid.draw(tableGrob(dat, rows=NULL))
    } else if (data.frame.theme == "flextable") {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits)
      library(flextable)
      tab = regulartable(dat) %>% theme_zebra() %>% autofit()
      return(knit_print(tab))
    } else {
      dat = pretty.df(x,signif.digits = signif.digits, round.digits = round.digits) 
      txt = paste0(capture.output(print(dat)), collapse="\n")
      return(txt)
    }
  }

}

format.vals = function(vals, signif.digits=NULL, round.digits=NULL) {
  if (is.numeric(vals)) {
    if (is.null(signif.digits) & is.null(round.digits)) {
      return(vals)
    } else if (!is.null(signif.digits) & is.null(round.digits)) {
      return(signif(vals, signif.digits))
    } else if (is.null(signif.digits) & !is.null(round.digits)) {
      return(round(vals, signif.digits))
    } else {
      return(signif(round(vals, round.digits), signif.digits))
    }
  }
  vals
}

max.size.df = function(x, max.rows=NULL, max.cols=NULL) {
  if (!is.null(max.rows)) {
    if (NROW(x)>max.rows) {
      x = x[1:max.rows,]
    }
  }
  if (!is.null(max.cols)) {
    if (NCOL(x)>max.cols) {
      x = x[,1:max.cols]
    }
  }
  x  
}

pretty.df = function(x, signif.digits=NULL, round.digits=NULL, max.rows=NULL, max.cols=NULL) {
  if (!is.null(max.rows) | ! is.null(max.cols))
    x = max.size.df(x, max.rows, max.cols)
  as.data.frame(lapply(x, format.vals, signif.digits=signif.digits, round.digits=round.digits))
}