Optimizing R scripts performing binomial calculations - php

Question

I'm trying to plot binomial curves using R scripts which are executed by PHP loops. The scripts are taking a very long time to run and I want to improve the algorithm to run faster.
The input values are:
$xmax = 360;
$p = 0.975;
$prvn = 1;
$b = 1.7;
$c = 0.995;
The PHP function called for each loop is:
function cg_graphs_get_binomial($xmax, $p, $prvn = 1, $b = 1.7, $c = 0.99){
$Alert = array();
/*run the Rscript file located in the module root*/
$Rgennloc = "/home/rcstest/www/".drupal_get_path('module', 'cg_graphs')."/Rbinomgenn.R"; //Rscript file location
$Rbinomloc = "/home/rcstest/www/".drupal_get_path('module', 'cg_graphs')."/Rbinomnew.R"; //Rscript file location
for($i = 0; $i <= $xmax; $i++){
exec("Rscript --slave ".$Rgennloc." ".$prvn." ".$i." ".$b, $n);
$ne = explode('[1]', $n[$i]);
$prvn = $ne[1];
exec("Rscript --slave ".$Rbinomloc." ".$prvn." ".$p." ".$c, $alert);
$at = explode('[1]', $alert[$i]);
$Alert[] = trim($at[1]);
}
return $Alert; //return the data array
The first R script called ($Rgennloc) generates the n value, based on the n value of the previous loop, or 1 if it is the first loop. This increments as follows (etc):
1
6
16
32
53
80
The first r script looks like this and runs in relatively short amount of time:
#!/usr/bin/Rscript
#grab args as passed into via CLI
args <- commandArgs(trailingOnly = TRUE)
#R script to generate n value
#implimentation of excel ROUNDDOWN function
ROUNDDOWN <- function(.number, .num_digits){
return(as.integer(.number*10^.num_digits)/(10^.num_digits))
}
#generate n
n <- function(.prvn, .xaxis, .B){
return(.prvn + ROUNDDOWN(.xaxis * exp(1)^.B, 0))
}
#wrapper function
n(as.integer(args[1]), as.integer(args[2]), as.double(args[3]))
When the second script is called, it runs quickly for about the first 20 calls (where n gets to around 1000 and xaxis is 20) but then it starts to slow down.
The second script:
#!/usr/bin/Rscript
# replace '/usr/bin' with actual R executable
args <- commandArgs(trailingOnly = TRUE)
#Critbinom - R implimentation of the excel function
CRITBINOM <- function(.trials, .probability_s, .alpha){
i <- 0
while(sum(dbinom(0:i, .trials, .probability_s)) < .alpha){
i <- i + 1
}
return(i)
}
# Binomdist - R implimentation of the excel function
BINOMDIST <- function(.number_s, .trials, .probability_s, .cumulative){
if(.cumulative){
return(sum(dbinom(0:.number_s, .trials, .probability_s)))
}else{
return(choose(.trials,.number_s)*.probability_s^.number_s*(1-.probability_s)^(.trials-.number_s))
}
}
# Iserror - R version of this, no need for all excel functionality.
ISERROR <- function(.value){
return(is.infinite(.value))
}
# Generate the alert
generate_Alert <- function(.n, .probability_s, .alpha){
critB <- CRITBINOM(.n, .probability_s, .alpha)
adj <- critB-(BINOMDIST(critB, .n, .probability_s,TRUE)-.alpha)/(BINOMDIST(critB, .n, .probability_s,TRUE)-BINOMDIST(critB-1, .n, .probability_s,TRUE))
if(ISERROR(100 * adj / .n)){
return(0)
}else{
adj_value <- (adj / .n)
return(adj_value)
}
}
# Generate the alert for current xaxis position
generate_data <- function(.n, .probability_s, .alpha){
Alert <- generate_Alert(.n, .probability_s, .alpha)
return(Alert)
}
# Call wrapper function generate_data(n, p, alpha)
generate_data(as.integer(args[1]), as.double(args[2]), as.double(args[3]))
The xaxis value may get as high as 360, but the script starts slowing down before xaxis gets to 30. By the time xaxis is at 100 it takes some 30 seconds to complete each loop, it just gets worse from there.
What is the best way of optimizing this? I think its only using 1 core at the moment. I have 2 available but I'm not sure how much difference the second core will make in the long run.
I am using the latest version of R.

Answer 1

Expanding my comment a bit, so this question gets an answer:
A while loop in R is a very unsual construct (I see it only once or twice a year in serious code). It's often an indicator that the code does not follow the spirit of R, but was written by someone with experience from other language (e.g., from the C familiy). while loops are very expensive performance-wise in R and if really needed should be better written in C.
Fortunately, the CRITBINOM function is just a naive re-implementation of qbinom (quantile function of the binomial distribution), which can be used instead. The only difference is in how multiple success probabilities are handled (qbinom is fully vectorized).
I believe a full reimplementation in R (avoiding explicit loops) could get this down to seconds or less, but I don't know PHP.