Случайное округление на 0,5 вверх или вниз с семенем в R

Question

У меня есть набор данных, содержащий нецелые значения, которые я хочу округлить до ближайшего целого числа. Это довольно просто, но мне нужна функция, которая делает две вещи в дополнение к простому округлению:

1. Он должен округлять половинки (0,5,1,5,2,5 и т. Д.) Случайным образом вверх или вниз, при этом всегда оставляя пол, например 2,4, и потолок, например 2,6

2. Я хочу, чтобы функция каждый раз давала одни и те же результаты, при этом округляя примерно половину средних дел, а половину - вниз.

Answer 1

Поскольку, согласно OP, не только числа, которые строго равны пределу округления.5, но и те, которые очень близки к нему, должны рассматриваться как кандидаты для случайного округления вверх или вниз, точное условие x%%1==0.5 может (или должен) быть отброшен. В этом случае достаточно добавить очень маленькое возмущение ко всем числам перед округлением. jitter() Функция добавляет такое случайное возмущение, которое влияет на результаты округления. Это делается воспроизводимым способом в зависимости от начального значения. Диапазон допуска, который определяет, какие числа являются "случайными кандидатами на округление", будет размером джиттера, который можно указать с помощью необязательного параметра. amount,

Поэтому можно использовать такую ​​функцию:

random_round <- function(x, seed = 123, tol = 1.e-6) { 
                  set.seed(seed) 
                  round(jitter(x, amount = tol))
                 }

Answer 2

Вы можете дополнительно векторизовать свое решение, используя ifelse, делая sapply ненужным:

FOO <- function(x, seed){
  set.seed(seed)
  ifelse(x %% 1 == .5, round(x + sample(c(-1, 1), 1) * .01), round(x))
}

test <- c(4.5, 3.4, 6.8, 3.5)

FOO(test, 1)
[1] 4 3 7 3

Это в несколько раз быстрее. Microbenchmark:

set.seed(10)
test <- sample(1:10, 10000, replace = T)
test <- test - sample(seq(0, 1, .1), 10000, replace = T)

microbenchmark(LAP = FOO(test, 1),
               Samuel = round_r(test), unit = "ms", times = 1000L)

Unit: milliseconds
   expr       min        lq      mean   median        uq      max neval cld
    LAP  1.172478  1.197225  1.493402  1.20718  1.237616 158.8736  1000  a 
 Samuel 41.040701 46.280868 50.014392 49.02561 52.908411 215.4537  1000   b

---

Другое, примерно на 30% более быстрое издание, предложенное @AndreElrico:

FOO2 <- function(x, seed){
  set.seed(seed)
  ifelse(x %% 1 == .5, sample(c(ceiling,floor),1)[[1]](x), round(x))
}

Answer 3

Я не думаю, что ты должен sapply() над каждым числом, когда вы можете просто векторизовать его.

round_rs <- function(x) {
  set.seed(111)
  x + sample(c(0.5, -0.5), length(x), replace = TRUE)
}

table(round_rs(v[v %% 1 == 0.5]))

Или завершите:

 round_rs <- function(x) {
  set.seed(111)
  rn <- v %% 1 == 0.5
  x[rn] <- x[rn] + sample(c(0.5, -0.5), sum(rn), replace = TRUE)
  x[!rn] <- round(x[!rn])
  x
}

microbenchmark(LAP1 = FOO(test, 1),
               erocoar = round_rs(test), 
               LAP2 = FOO2(test), unit = "ms", times = 1000L)

Unit: milliseconds
    expr      min       lq      mean   median       uq       max neval
    LAP1 1.388751 1.402546 1.8448210 1.488841 1.631277 77.461753  1000
 erocoar 0.464842 0.472542 0.7619839 0.483449 0.535098 75.046116  1000
    LAP2 0.994486 1.009243 1.2846360 1.061694 1.165955  3.814334  1000

Answer 4

РЕДАКТИРОВАТЬ: Основываясь на RHertel, я отредактировал код, чтобы лучше соответствовать этому конкретному случаю.

На первом этапе создается функция, которая колеблется и округляет значения, очень близкие к n + 0,5. На этапе II функция применяется ко всем нецелым значениям при заданных переменных.

НАСТРОИТЬ

library(tidyverse)
var1 <- c(rep(10.5,10^4),rep(20.1,10^4),rep(30.9,10^4))
var2 <- c(rep(10.5,10^4),rep(20.1,10^4),rep(30.9,10^4))
data <- as.data.frame(cbind(var1,var2))

Фаза I

round_r <- function(x,seed=111, tol=1.e-6) { 
  set.seed(seed) 
  round(ifelse(near(x%%1,0.5), jitter(x, amount = tol), x))
}

Фаза II

data2 <- data %>% mutate_at(vars(var1,var2),
                      funs(ifelse(.==.%/%1,.,round_r(.))))

# results
table(data)
table(data2)

> table(data)
var2
var1  10.5  20.1  30.9
10.5 10000     0     0
20.1     0 10000     0
30.9     0     0 10000

> table(data2)
var2
var1  10    11    20    31
10  4994     0     0     0
11     0  5006     0     0
20     0     0 10000     0
31     0     0     0 10000

Не забудьте стереть строку с помощью set.seed, если вы хотите действительно случайные округления!

Если код еще можно улучшить, я бы хотел услышать!