2

我正在尝试使用由 PHP 循环执行的 R 脚本绘制二项式曲线。脚本需要很长时间才能运行，我想改进算法以更快地运行。

输入值为：

$xmax = 360;
$p = 0.975;
$prvn = 1;
$b = 1.7;
$c = 0.995;

每个循环调用的 PHP 函数是：

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

第一个名为 ($Rgennloc) 的 R 脚本根据前一个循环的 n 值生成 n 值，如果是第一个循环，则为 1。这增量如下（等）：

1 6 16 32 53 80

第一个 r 脚本如下所示，运行时间相对较短：

#!/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]))

当第二个脚本被调用时，它会在前 20 次调用中快速运行（其中 n 大约为 1000，xaxis 为 20），但随后开始变慢。

第二个脚本：

#!/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]))

xaxis 值可能高达 360，但脚本在 xaxis 达到 30 之前开始减速。当 xaxis 达到 100 时，完成每个循环需要大约 30 秒，从那里开始变得更糟。

优化它的最佳方法是什么？我认为它目前只使用 1 个核心。我有 2 个可用，但我不确定第二个核心从长远来看会有多大的不同。

我正在使用最新版本的 R。

4

1 回答 1

1

稍微扩展我的评论，所以这个问题得到了答案：

R 中的while循环是一个非常不寻常的构造（我在严肃的代码中每年只看到一两次）。这通常表明代码没有遵循 R 的精神，而是由具有其他语言经验的人编写的（例如，来自 C 家族）。while循环在 R 中的性能方面非常昂贵，如果确实需要，应该更好地用 C 编写。

幸运的是，该函数只是（二项分布的分位数函数）的CRITBINOM简单重新实现，可以使用它来代替。qbinom唯一的区别在于如何处理多个成功概率（qbinom完全矢量化）。

我相信在 R 中完全重新实现（避免显式循环）可以将其缩短到几秒钟或更短，但我不了解 PHP。

于 2013-05-28T07:07:03.477 回答