2015-10-20 20 views
5

Grafiksel bir çizim yapmadan önce veri kümesini alt yapıyorum, ancak anahtar sayısal olarak match() veya %in% katı eşitlik testini kullanamıyorum (birkaç değeri özlüyor). Aşağıdaki alternatifi yazdım, ama bu sorunun bir yerde daha iyi bir yerleşik alternatif olduğu yeterince yaygın olduğunu düşünüyorum. all.equal, birden çok test değeri için tasarlanmamış gibi gözükmemektedir.match() toleransla değerleri

`%~%` <- function(x,y) sapply(x, function(.x) { 
any(sapply(y, function(.y) isTRUE(all.equal(.x, .y, tolerance=tol)))) 
}) 

x %~% c(1,2,3) 
[1] TRUE TRUE FALSE TRUE FALSE TRUE 

İki orada işlevleri uygulamak zorunda sevmiyorum: Bu all.equal ama ne kadar iyi

select_in <- function(x, ref, tol=1e-10){ 
    testone <- function(value) abs(x - value) < tol 
    as.logical(rowSums(sapply(ref, testone))) 
} 

x = c(1.0, 1+1e-13, 1.01, 2, 2+1e-9, 2-1e-11) 
x %in% c(1,2,3) 
#[1] TRUE FALSE FALSE TRUE FALSE FALSE 
select_in(x, c(1, 2, 3)) 
#[1] TRUE TRUE FALSE TRUE FALSE TRUE 
+1

@Frank nope :) bir yanıt olarak gönderin – baptiste

+1

@Frank harika bir fikir! –

cevap

6

:

fselect_in <- function(x, ref, d = 10){ 
    round(x, digits=d) %in% round(ref, digits=d) 
} 

fselect_in(x, c(1,2,3)) 
# TRUE TRUE FALSE TRUE FALSE TRUE 
+0

ref, ben aynı hassas hem x ve ref yuvarlak zorunda kaldı – baptiste

2

emin değil çalışacak bir tolerans argüman vardır. Kısaltmaya çalışacağım.

güncelleme

hızlı all.equal kullanmadan olabilir başka yolu. İlk çözümü çok daha hızlı olarak çıkıyor:

`%~%` <- function(x,y) { 
out <- logical(length(x)) 
for(i in 1:length(x)) out[i] <- any(abs(x[i] - y) <= tol) 
out 
} 

x %~% c(1,2,3) 
[1] TRUE TRUE FALSE TRUE FALSE TRUE 

Benchmark Bu hedefe (oldukça toleransla olsa) elde etmek görünüyor

big.x <- rep(x, 1e3) 
big.y <- rep(y, 100) 

all.equal(select_in(big.x, big.y), big.x %~% big.y) 
[1] TRUE 

library(microbenchmark) 
microbenchmark(
    baptiste = select_in(big.x, big.y), 
    plafort2 = big.x %~% big.y, 
    times=50L) 
Unit: milliseconds 
    expr  min  lq  mean median  uq  max 
baptiste 185.86828 199.57517 231.28246 244.81980 261.7451 271.3426 
plafort2 49.03265 54.30729 84.88076 66.10971 118.3270 123.1074 
neval cld 
    50 b 
    50 a 
+0

İkinci çözümün OP'den hangisinin farklı olduğunu merak ediyorum. –

+0

Yakın, ama muhtemelen değer katmak için yeterince farklı olduğunu düşünüyorum. –

+0

x üzerinde dönüyorsunuz, ref üzerinden dönerken, bu yüzden farklı. Benim özel durumumda 'boy (ref) << uzunluk (x) ', eğer bir döngü kullanılmalıysa, bunu muhtemelen benim yolumda yapmak daha iyidir. – baptiste

2

length(x) * length(ref)'dan kaçınmanın başka bir fikri:

ff = function(x, ref, tol = 1e-10) 
{ 
    sref = sort(ref) 
    i = findInterval(x, sref, all.inside = TRUE) 
    dif1 = abs(x - sref[i]) 
    dif2 = abs(x - sref[i + 1]) 
    dif = dif1 > dif2 
    dif1[dif] = dif2[dif] 
    dif1 <= tol 
} 
ff(c(1.0, 1+1e-13, 1.01, 2, 2+1e-9, 2-1e-11), c(1, 2, 3)) 
#[1] TRUE TRUE FALSE TRUE FALSE TRUE 

Ve karşılaştırmak için:

set.seed(911) 
X = sample(1e2, 5e5, TRUE) + (sample(c(1e-8, 1e-9, 1e-10, 1e-12, 1e-13), 5e5, TRUE) * sample(c(-1, 1), 5e5, TRUE)) 
REF = as.double(1:1e2) 

all.equal(ff(X, REF), select_in(X, REF)) 
#[1] TRUE 
tol = 1e-10 #set this for Pierre's function 
microbenchmark::microbenchmark(select_in(X, REF), fselect_in(X, REF), X %~% REF, ff(X, REF), { round(X, 10); round(REF, 10) }, times = 35) 
#Unit: milliseconds 
#         expr  min   lq  median   uq  max neval 
#      select_in(X, REF) 1259.95876 1324.52371 1380.10492 1428.78677 1495.61810 35 
#      fselect_in(X, REF) 121.47241 123.72678 125.28932 128.56770 142.15676 35 
#        X %~% REF 2023.78159 2088.97226 2161.66973 2219.46164 2547.89849 35 
#        ff(X, REF) 67.35003 69.39804 71.20871 73.22626 94.04477 35 
# {  round(X, 10)  round(REF, 10) } 96.20344 96.88344 99.10093 102.66328 117.75189 35 

Frank matchfindInterval daha hızlı olacak ve gerçektendir, round içinde en fazla vakit geçiren olmalıdır.