#
# Copyright (c) 2017 Structured Data LLC
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#
# we need a module for the graphics device because R wants to free()
# it and we can't agree on an allocator (not sure why not). since we
# have a module, though, this will probably become the default location
# for R functions. nice to have a real namespace as well.
#
#' @useDynLib BERTModule
NA
#==============================================================================
#
# scratch
#
#==============================================================================
data.env <- new.env();
#==============================================================================
#
# utility functions
#
#==============================================================================
#' Convert a list of lists into a data frame
#'
#' Spreadsheet functions that accept a range as an argument and range values
#' returned by the COM/scripting API may be returned as list-of-list
#' structures. BERT does that to preserve type information; R vectors can't
#' contain mixed types. This function will convert a list-of-lists structure
#' into a data frame, optionally with column headers.
#'
#' @export range.to.data.frame
range.to.data.frame <- function( rng, headers=F ){
# remove headers from data if necessary
data <- if(headers) rng[-1,] else rng;
# format data
if( is.null( ncol(data))){
# special case
df <- as.data.frame( unlist( data ));
}
else {
df <- as.data.frame( lapply( split( data, col(data)), unlist ));
}
# add headers if available
if( headers ){ colnames(df) <- rng[1,]; }
# done
df;
}
#==============================================================================
#
# graphics device
#
#==============================================================================
#' Create a BERT graphics device.
#'
#' \code{BERT.graphics.device} creates a graphics device that renders to
#' a named Shape in an Excel workbook.
#'
#' If this is called from an Excel spreadsheet cell, set \code{cell=TRUE}
#' and it will use a name that's generated from the cell address, which
#' should be unique in the workbook. (That won't survive sheet renaming,
#' but in that case just toss the old one and a new one will be generated
#' on the next paint).
#'
#' Size, background and pointsize arguments are ignored if the target
#' named shape already exists. The values for these arguments are
#' scaled based on reported screen DPI to give reasonable values on
#' normal and high-DPI displays (to prevent this behavior, set the scale
#' parameter to 1).
#'
#' @export
BERT.graphics.device <- function( name="BERT-default", bgcolor="white", width=400, height=400, pointsize=14, scale=Sys.getenv("BERTGraphicsScale"), cell=F ){
scale <- as.numeric(scale);
if(is.na(scale) | is.null(scale)){ scale = 1; }
width = round( width * scale );
height = round( height * scale );
pointsize = round( pointsize * scale );
if( cell ){
ref <- BERT$.Excel(89); # xlfCaller
sheetnm <- BERT$.Excel(0x4005, list(ref)); # xlSheetNm
name = paste0( gsub( "\\[.*?\\]", "", sheetnm ), " R", ref@R1, " C", ref@C1 );
}
x <- dev.list();
if((length(x) > 0) & (name %in% names(x))){ dev.set( x[[name]]) }
else {
.Call( "create_device", name, bgcolor, width, height, pointsize, PACKAGE='BERTModule' );
}
}
#==============================================================================
#
# progress bars
#
#==============================================================================
with( data.env, {
progress.bar.list <- list();
progress.bar.key <- 1;
});
js.client.progress.bar <- function( min=0, max=1, initial=min, ... ){
key <- data.env$progress.bar.key;
struct <- list( key=key, min=min, max=max, initial=initial, value=initial, ... );
handle <- list( key=key );
class(handle) <- "js.client.progress.bar";
pblist <- data.env$progress.bar.list;
pblist[[toString(key)]] <- struct;
assign( "progress.bar.list", pblist, envir=data.env );
assign( "progress.bar.key", key + 1, envir=data.env );
invisible(.Call("progress_bar", struct, PACKAGE="BERTModule" ));
return(handle);
}
js.client.get.progress.bar <- function( pb ){
struct <- data.env$progress.bar.list[[toString(pb$key)]];
return( struct$value );
}
js.client.set.progress.bar <- function( pb, value, title=NULL, label=NULL ){
struct <- data.env$progress.bar.list[[toString(pb$key)]];
struct$value <- value;
if( !is.null(label)){ struct$label = label }
pblist <- data.env$progress.bar.list;
pblist[[toString(pb$key)]] <- struct;
assign( "progress.bar.list", pblist, envir=data.env );
invisible(.Call("progress_bar", struct, PACKAGE="BERTModule" ));
return( struct$value );
}
#' Generic method for BERT shell progress bar
#'
#' @export
close.js.client.progress.bar <- function( pb ){
struct <- data.env$progress.bar.list[[toString(pb$key)]];
struct$closed <- T;
invisible(.Call("progress_bar", struct, PACKAGE="BERTModule" ));
pblist <- data.env$progress.bar.list;
pblist[[toString(pb$key)]] <- NULL;
assign( "progress.bar.list", pblist, envir=data.env );
}
#==============================================================================
#
# history (just calls into BERT; but we have a special print generic)
#
#==============================================================================
#' Print console history
#'
#' @export
print.history.list <- function(h){
len <- length(h);
pattern <- paste( " %s\n", sep="" );
cat( "\n" );
for( i in 1:len ){ cat( sprintf( pattern, h[i] )); }
cat( "\n" );
}
#' History implementation for the BERT console
#'
history <- function( max.show=25, reverse=FALSE, pattern="" ){
.Call( "history", list(max.show, reverse, pattern), PACKAGE="BERTModule" );
}
#==============================================================================
#
# functions for using the Excel COM interface
#
#==============================================================================
#' create a wrapper for a dispatch pointer
.WrapDispatch <- function( class.name = NULL ){
obj <- new.env();
if( is.null( class.name )){ class(obj) <- "IDispatch"; }
else { class(obj) <- c( class.name, "IDispatch" ) };
return(obj);
}
#' callback function for handling com calls
.DefineCOMFunc <- function( func.name, func.type, func.args, target.env ){
if( missing( func.args ) || length(func.args) == 0 ){
target.env[[func.name]] <- function(...){
#.Call(.COM_CALLBACK, func.name, func.type, target.env$.p, list(...), PACKAGE=.MODULE );
.Call("COM_Callback", func.name, func.type, target.env$.p, list(...), PACKAGE="BERTModule" );
}
}
else {
target.env[[func.name]] <- function(){
#.Call(.COM_CALLBACK, func.name, func.type, target.env$.p, c(as.list(environment())), PACKAGE=.MODULE );
.Call("COM_Callback", func.name, func.type, target.env$.p, c(as.list(environment())), PACKAGE="BERTModule" );
}
aexp <- paste( "alist(", paste( sapply( func.args, function(x){ paste( x, "=", sep="" )}), collapse=", " ), ")" );
formals(target.env[[func.name]]) <- eval(parse(text=aexp));
}
}
#==============================================================================
#
# autocomplete
#
#==============================================================================
.Autocomplete <- function(...){
ac <- utils:::.win32consoleCompletion(...);
if( length( utils:::.CompletionEnv$comps) > 0 ){
ac$comps <- paste( utils:::.CompletionEnv$comps, collapse='\n' );
}
ac$function.signature <- ifelse( is.null( utils:::.CompletionEnv$function.signature ), "", utils:::.CompletionEnv$function.signature );
ac$token <- ifelse( is.null( utils:::.CompletionEnv$token ), "", utils:::.CompletionEnv$token );
ac$fguess <- ifelse( is.null( utils:::.CompletionEnv$fguess ), "", utils:::.CompletionEnv$fguess );
ac$start <- utils:::.CompletionEnv$start;
ac$end <- utils:::.CompletionEnv$end;
# ac$file.name <- utils:::.CompletionEnv$fileName;
ac$in.quotes <- utils:::.CompletionEnv$in.quotes;
ac;
}
#
# this is a monkeypatch for the existing R autocomplete # functionality. we are making two
# changes: (1) for functions, store the signagure for use as a call tip. (2) for functions
# within environments, resolve and get parameters.
#
# update: now delegating file completion to C (probably more to come).
#
.CustomCompleter <- function(.CompletionEnv){
.fqFunc <- function (line, cursor=-1)
{
localBreakRE <- "[^\\.\\w\\$\\@\\:]";
if( cursor == -1 ){ cursor = nchar(line); }
parens <- sapply(c("(", ")"), function(s) gregexpr(s, substr(line,
1L, cursor), fixed = TRUE)[[1L]], simplify = FALSE)
parens <- lapply(parens, function(x) x[x > 0])
temp <- data.frame(i = c(parens[["("]], parens[[")"]]), c = rep(c(1,
-1), lengths(parens)))
if (nrow(temp) == 0)
return(character())
temp <- temp[order(-temp$i), , drop = FALSE]
wp <- which(cumsum(temp$c) > 0)
if (length(wp)) {
index <- temp$i[wp[1L]]
prefix <- substr(line, 1L, index - 1L)
suffix <- substr(line, index + 1L, cursor + 1L)
if ((length(grep("=", suffix, fixed = TRUE)) == 0L) &&
(length(grep(",", suffix, fixed = TRUE)) == 0L))
utils:::setIsFirstArg(TRUE)
if ((length(grep("=", suffix, fixed = TRUE))) && (length(grep(",",
substr(suffix, utils:::tail.default(gregexpr("=", suffix,
fixed = TRUE)[[1L]], 1L), 1000000L), fixed = TRUE)) ==
0L)) {
return(character())
}
else {
possible <- suppressWarnings(strsplit(prefix, localBreakRE,
perl = TRUE))[[1L]]
possible <- possible[nzchar(possible)]
if (length(possible))
return(utils:::tail.default(possible, 1))
else return(character())
}
}
else {
return(character())
}
}
.fqFunctionArgs <- function (fun, text, S3methods = utils:::.CompletionEnv$settings[["S3"]],
S4methods = FALSE, add.args = rc.getOption("funarg.suffix"))
{
.resolveObject <- function( name ){
p <- environment();
n <- unlist( strsplit( name, "[^\\w\\.,]", F, T ));
while( length( n ) > 1 ){
if( n == "" || !exists( n[1], where=p )) return( NULL );
p <- get( n[1], envir=p );
n <- n[-1];
}
if( n == "" || !exists( n[1], where=p )) return( NULL );
list( name=n[1], fun=get( n[1], envir=p ));
}
.function.signature <- function(fun){
x <- capture.output( args(fun));
paste(trimws(x[-length(x)]), collapse=" ");
}
.fqArgNames <- function (fname, use.arg.db = utils:::.CompletionEnv$settings[["argdb"]])
{
funlist <- .resolveObject( fname );
fun <- funlist$fun;
if( !is.null(fun) && is.function(fun )) {
env <- utils:::.CompletionEnv;
env$function.signature <- sub( '^function ', paste0( funlist$name, ' ' ), .function.signature(fun));
return(names( formals( fun )));
}
return( character());
};
if (length(fun) < 1L || any(fun == ""))
return(character())
specialFunArgs <- utils:::specialFunctionArgs(fun, text)
if (S3methods && exists(fun, mode = "function"))
fun <- c(fun, tryCatch(methods(fun), warning = function(w) {
}, error = function(e) {
}))
if (S4methods)
warning("cannot handle S4 methods yet")
allArgs <- unique(unlist(lapply(fun, .fqArgNames)))
ans <- utils:::findMatches(sprintf("^%s", utils:::makeRegexpSafe(text)),
allArgs)
if (length(ans) && !is.null(add.args))
ans <- sprintf("%s%s", ans, add.args)
c(specialFunArgs, ans)
}
.CompletionEnv[["function.signature"]] <- "";
.CompletionEnv[["in.quotes"]] <- F;
text <- .CompletionEnv[["token"]]
if (utils:::isInsideQuotes()) {
{
.CompletionEnv[["comps"]] <- character()
.CompletionEnv[["in.quotes"]] <- T;
utils:::.setFileComp(TRUE)
}
}
else {
utils:::.setFileComp(FALSE)
utils:::setIsFirstArg(FALSE)
guessedFunction <- if (.CompletionEnv$settings[["args"]])
.fqFunc(.CompletionEnv[["linebuffer"]], .CompletionEnv[["start"]])
else ""
.CompletionEnv[["fguess"]] <- guessedFunction
fargComps <- .fqFunctionArgs(guessedFunction, text)
if (utils:::getIsFirstArg() && length(guessedFunction) && guessedFunction %in%
c("library", "require", "data")) {
.CompletionEnv[["comps"]] <- fargComps
return()
}
lastArithOp <- utils:::tail.default(gregexpr("[\"'^/*+-]", text)[[1L]],
1)
if (haveArithOp <- (lastArithOp > 0)) {
prefix <- substr(text, 1L, lastArithOp)
text <- substr(text, lastArithOp + 1L, 1000000L)
}
spl <- utils:::specialOpLocs(text)
comps <- if (length(spl))
utils:::specialCompletions(text, spl)
else {
appendFunctionSuffix <- !any(guessedFunction %in%
c("help", "args", "formals", "example", "do.call",
"environment", "page", "apply", "sapply", "lapply",
"tapply", "mapply", "methods", "fix", "edit"))
utils:::normalCompletions(text, check.mode = appendFunctionSuffix)
}
if (haveArithOp && length(comps)) {
comps <- paste0(prefix, comps)
}
comps <- c(fargComps, comps)
.CompletionEnv[["comps"]] <- comps
}
};
#==============================================================================
#
# exported generics for xlReference
#
#==============================================================================
#' @export nrow
nrow.xlReference <- function(x){
if( x@R2 >= x@R1 ){ return( x@R2-x@R1+1 ); }
else{ return(1); }
}
#' @export ncol
ncol.xlReference <- function(x){
if( x@C2 >= x@C1 ){ return( x@C2-x@C1+1 ); }
else{ return(1); }
}
#==============================================================================
#
# .onLoad
#
#==============================================================================
.onLoad <- function(libname, pkgname){
#-----------------------------------------------------------------------------
# replace win progress bar with an inline progress bar.
#-----------------------------------------------------------------------------
override.binding <- function( name, func, ns, assign.in.namespace=T ){
if( exists( name ) ){
package <- paste0( "package:", ns );
unlockBinding( name, as.environment(package));
assign( name, func, as.environment(package));
if( assign.in.namespace ){
ns <- asNamespace( ns );
if (bindingIsLocked(name, ns)) {
unlockBinding(name, ns)
assign(name, func, envir = ns, inherits = FALSE)
w <- options("warn")
on.exit(options(w))
options(warn = -1)
lockBinding(name, ns)
}
else assign(name, func, envir = ns, inherits = FALSE);
}
lockBinding( name, as.environment(package));
}
}
override.binding( "winProgressBar", js.client.progress.bar, "utils");
override.binding( "setWinProgressBar", js.client.set.progress.bar, "utils");
override.binding( "getWinProgressBar", js.client.get.progress.bar, "utils");
override.binding( "txtProgressBar", js.client.progress.bar, "utils");
override.binding( "setTxtProgressBar", js.client.set.progress.bar, "utils");
override.binding( "getTxtProgressBar", js.client.get.progress.bar, "utils");
#-----------------------------------------------------------------------------
# create a "js" download method, and set that as default
#-----------------------------------------------------------------------------
download.file.original <- get( "download.file", envir=as.environment( "package:utils" ));
override.binding( "download.file",
function (url, destfile, method, quiet = FALSE, mode = "w", cacheOK = TRUE,
extra = getOption("download.file.extra"))
{
method <- if (missing(method))
getOption("download.file.method", default = "auto")
else match.arg(method, c("auto", "internal", "wininet", "libcurl",
"wget", "curl", "lynx", "js"))
if( method == "js" ){
invisible(.Call("download", as.list(environment()), PACKAGE="BERTModule" ));
}
else {
do.call( download.file.original, as.list(environment()), envir=parent.env(environment()));
}
}, "utils", T );
options( download.file.method="js" );
#-----------------------------------------------------------------------------
# overload history for the console
#--------------------------------------------------------
override.binding( "history", history, "utils");
#-----------------------------------------------------------------------------
# override quit so it doesn't kill the excel process
#-----------------------------------------------------------------------------
quit <- function(){ invisible(.Call("close_console", struct, PACKAGE="BERTModule" )); }
override.binding( "quit", quit, "base");
override.binding( "q", quit, "base");
#-----------------------------------------------------------------------------
# autocomplete
#-----------------------------------------------------------------------------
rc.options( custom.completer=.CustomCompleter );
#-----------------------------------------------------------------------------
# xlReference: s4 class type representing an Excel cell reference. this
# was more useful before we added the COM interface, but it still might
# be handy.
#-----------------------------------------------------------------------------
setClass( "xlReference",
slots = c( R1 = "numeric", C1 = "numeric", R2 = "numeric", C2 = "numeric", SheetID = "numeric" ),
prototype = list( R1 = 0, C1 = 0, R2 = 0, C2 = 0, SheetID = c(0,0))
);
# why can't nrow and ncol be defined the same way as show?
# it just doesn't work. in any event these need to be exported.
suppressMessages(setMethod( "nrow", "xlReference", nrow.xlReference ));
suppressMessages(setMethod( "ncol", "xlReference", ncol.xlReference ));
# this one seems to work regardless
setMethod( "show", "xlReference", function(object){
cat( "Excel Reference ", "R", object@R1, "C", object@C1, sep="" );
if( object@R2 > object@R1 || object@C2 > object@C1 )
{
cat( ":", "R", object@R2, "C", object@C2, sep="" );
}
if( object@SheetID[1] != 0 || object@SheetID[2] != 0 )
{
cat( " SheetID ", object@SheetID[1], ".", object@SheetID[2], sep="");
}
cat( "\n" );
});
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.