typedFunction.R

# > source("typedFunction.R")
#
# > cat(src)
# double calcPiLoop_typed() {
# int circle_in;
# int i;
# double l;
#
# circle_in = 0;
# for (i = 1; i <= 1e+08; i++) {
# l = sqrt(pow(R::runif(0.0, 1.0), 2) + pow(R::runif(0.0, 1.0), 2));
# if (l <= 1) {
# circle_in = circle_in + 1;
# } ;
# };
# return(4 * circle_in / 1e+08);
# }
#
# > system.time(calcPiLoop())
#    ユーザ   システム       経過  
#    745.301     93.825    839.292 
# > system.time(calcPiVector())
#    ユーザ   システム       経過  
#      9.806      1.197     11.168 
# > system.time(calcPiLoopCpp())
#    ユーザ   システム       経過  
#      3.245      0.008      3.258 
# > system.time(calcPiLoop_typed())
#    ユーザ   システム       経過  
#      3.240      0.008      3.254 

library("Rcpp")

typedFunction <- function(closure, ...) {
  type <- list(...)
  func.name <- as.character(substitute(closure))
  func.type <- type[[func.name]]
  type[[func.name]] <- NULL

  cppformals <- function() {
    formals <- names(formals(closure))
    if (length(formals) == 0) ""
    else Reduce(function(a, b) paste(a, b, sep=", "),
                Map(function(n) paste(type[[n]], n, sep=" "),
                    formals))
  }

  cpptypedecs <- function() {
    formals <- names(formals(closure))
    type[formals] <- NULL
    if (length(names(type)) == 0) ""
    else paste(Reduce(function(a, b) paste(a, b, sep=";\n"),
                      Map(function(n) paste(type[[n]], n, sep=" "),
                          names(type))),
               ";\n", sep="")
  }

  cppbody <- function() {
    body <- body(closure)	

    visit.exp <- function(e) {
      if (is.symbol(e) || is.numeric(e)) return(as.character(e))
      op <- as.character(e[[1]])
      args <- e[-1]
      if (op == 'for') visit.for(args)
      else if (op == 'if') visit.if(args)
      else if (op %in% c('+', '-', '*', '/', '^', '<-', '=',
                         '>', '>=', '<', '<=', '==')) {
        visit.binop(op, args)
      }
      else if (op == '{') visit.block(args)
      else if (op == '(') visit.paren(args)
      else visit.funcall(op, args)
    }
    
    visit.binop <- function(op, args) {
      if (op == '^') return(visit.funcall('pow', args))
      if (op == '<-') op <- '='
      arg1 <- visit.exp(args[[1]])
      arg2 <- visit.exp(args[[2]])
      sprintf("%s %s %s", arg1, op, arg2)
    }

    visit.for <- function(args) {
      var <- as.character(args[[1]])
      range <- args[[2]]
      body <- visit.exp(args[[3]])

      if (range[[1]] != quote(`:`)) stop("for: range error")
      begin <- visit.exp(range[[2]])
      end <- visit.exp(range[[3]])

      sprintf("for (%s = %s; %s <= %s; %s++) {\n%s\n}",
              var, begin, var, end, var, body)
    }
    
    visit.if <- function(args) {
      cond <- visit.exp(args[[1]])
      tclause <- sprintf("{\n%s\n}", visit.exp(args[[2]]))
      else_fclause <- if (length(args) == 3) {
                        sprintf(" else {\n%s\n}", visit.exp(args[[3]]))
                      }
                      else ""
      sprintf("if (%s) %s%s",  cond, tclause , else_fclause)
    }

    visit.block <- function(args) {
      sprintf("%s;",
              Reduce(function(a, b) paste(a, b, sep=";\n"),
                     Map("visit.exp", args)))
    }

    visit.funcall <- function(op, args) {
      args <- if (length(args) == 0) ""
              else Reduce(function(a, b) paste(a, b, sep=", "),
                          Map("visit.exp", args))
      if (op == 'runif') #tenuki!
        "R::runif(0.0, 1.0)"
      else
        sprintf("%s(%s)", op, args)
    }

    visit.paren <- function(args) {
      sprintf("(%s)", visit.exp(args[[1]]))
    }

    visit.body <- function(body) {
      if (is.call(body) && (body[[1]] == quote(`{`))) {
        args <- body[-1]
        last <- args[[length(args)]]
	if (!is.call(last) || !(last[[1]] == as.name('return'))) {
	  last <- list(as.name('return'), last)
	  args[[length(args)]] <- last
	}
	visit.block(args)
      }
      else sprintf("return %s;", visit.exp(body))
    }

    visit.body(body)
  }

  sprintf("%s %s_typed(%s) {\n%s\n%s\n}\n",
          func.type,
          func.name,
          cppformals(),
          cpptypedecs(),
          cppbody())
}

calcPiLoop <- function() {
  circle_in <- 0
  for (i in 1:100000000) {
    l <- sqrt(runif(1)^2 + runif(1)^2)
    if (l <= 1) {
      circle_in <- circle_in + 1      
    }
  }
  4.0 * circle_in / 100000000 
}

calcPiVector <- function() {
  x <- runif(100000000)
  y <- runif(100000000)
  d <- sqrt(x^2 + y^2)
  return(4 * sum(d < 1.0) / 100000000)
}

cppFunction(
"double calcPiLoopCpp() {
  int circle_in = 0;
  for (int i = 1; i <= 100000000; i++) {
    double l = sqrt(pow(R::runif(0.0, 1.0), 2) +
                    pow(R::runif(0.0, 1.0), 2));
    if (l <= 1) {
      circle_in = circle_in + 1;
    }
  }
  return 4.0 * circle_in / 100000000;
}"
)

src <- typedFunction(calcPiLoop, calcPiLoop='double', circle_in='int', i='int', l='double')
cppFunction(src)