R - улучшение скорости выборочной функции

Question

Предположим, у меня есть следующая структура данных:

sl_sev_disbn <- data.frame("lower_band" = c(0,10e6,20e6,30e6,0,0,0),
                           "upper_band" = c(10e6,20e6,30e6,40e6,0,0,0),
                           "prob" = c(0.56521739,0.34782609,0.08212560,0.00483092,0,0,0),
                           "band" = c(1,2,3,4,5,6,7))

Я хочу случайной выборкой "полосы" из этого кадра данных, используя заданные вероятности в качестве весов. Из этой полосы я хочу сэмплировать случайное число равномерно из заданных нижней и верхней полос, сохранить каждую выборку и вернуть ее в вектор. У меня есть следующий код:

rsuper_lrg_disbn <- function(n = 1,df){

  band_sample <- sample(x = df$band, size = n, prob = df$prob,replace=TRUE)

  vals <- c()
  for (band in band_sample){
    filt_df <- df[df$band == band,] #filter to randomly selected band

    loss <- runif(1,min=filt_df$lower_band,max=filt_df$upper_band)

    vals <- c(vals,loss)

  }

  return(vals)
}

Тогда его использование будет выглядеть так: rsuper_lrg_disbn(n=2,sl_sev_disbn)

Однако этот код сильно замедляется, если я использую очень большое значение n, такое как n = 1e6.

Кто-нибудь знает, как я могу ускорить это?

Answer 1

Воспользуйтесь тем, что runif векторизовано!

sl_sev_disbn <- data.frame("lower_band" = c(0,10e6,20e6,30e6,0,0,0),
                           "upper_band" = c(10e6,20e6,30e6,40e6,0,0,0),
                           "prob" = c(0.56521739,0.34782609,0.08212560,0.00483092,0,0,0),
                           "band" = c(1,2,3,4,5,6,7))
rsuper_lrg_disbn <- function(n = 1,df){

  band_sample <- sample(x = df$band, size = n, prob = df$prob,replace=TRUE)

  vals <- c()
  for (band in band_sample){
    filt_df <- df[df$band == band,] #filter to randomly selected band

    loss <- runif(1,min=filt_df$lower_band,max=filt_df$upper_band)

    vals <- c(vals,loss)

  }

  return(vals)
}

fast_samp <- function(n = 1, df) {
  band_sample <- sample(x = df$band, size = n, prob = df$prob,replace=TRUE)
  vals <- runif(n, min = df[band_sample, 'lower_band'], max = df[band_sample, 'upper_band'])
  return(vals)
}

## same dist
summary(rsuper_lrg_disbn(n = 3e4, sl_sev_disbn))
#>     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
#>      832  4428211  8903344 10290102 15373486 39992683
summary(fast_samp(n = 3e4, sl_sev_disbn))
#>     Min.  1st Qu.   Median     Mean  3rd Qu.     Max. 
#>     2278  4435472  8827781 10261747 15312544 39703908

library(microbenchmark)
microbenchmark(rsuper_lrg_disbn(n = 1e3, sl_sev_disbn),
               fast_samp(n = 1e3, sl_sev_disbn))
#> Unit: microseconds
#>                                      expr       min        lq       mean
#>  rsuper_lrg_disbn(n = 1000, sl_sev_disbn) 36032.381 37381.912 38232.6291
#>         fast_samp(n = 1000, sl_sev_disbn)    75.062    79.012   115.8676
#>     median        uq       max neval
#>  37672.677 38327.886 60730.445   100
#>     89.284    92.444  2689.974   100

^{Создано в 2019-10-16 пакетом Представить (v0.3.0)}