Несколько лет назад я написал несколько функций bc, чтобы обеспечить округление чисел до ближайшего заданного значения с дополнительным смещением, а также поддержку шести общих типов tiebreaking rules. На ваш вопрос я попытался передать свой код R.
Здесь есть существенная оговорка, связанная с точностью. Так как R использует кодирование с плавающей запятой для представления дробных чисел, вы можете очень легко получить недостаточную точность, чтобы правильно применять правила tiebreaking. Это вызвано тем фактом, что разница между нескорректированным результатом округления и интервалом округления может отклоняться от половины единицы просто из-за ошибки с плавающей запятой, и поэтому она может становиться необнаруживаемой, независимо от того, следует ли применять tiebreaking вообще. Это не было проблемой для моего исходного кода, потому что bc - калькулятор с бесконечной точностью, но это проблема в R. Я попытался смягчить эту проблему, выполнив вычисления с мягкой толерантностью, но это не идеально. Если порядок величины интервала округления слишком сильно отличается от порядка величины округления значения, результат будет неверным. Но, следует упомянуть, это оговорка относится к любому решению, которое использует арифметику с плавающей запятой, а не только мой код.
Во всяком случае, вот что я получил:
FTOL <- 1e-8;
feq <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),abs(a-b)<=max(abs(a),abs(b))*tol,a==b);
fne <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),abs(a-b)>max(abs(a),abs(b))*tol,a!=b);
fgt <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),a-b>max(abs(a),abs(b))*tol,a>b);
fge <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),a-b>=-max(abs(a),abs(b))*tol,a>=b);
flt <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),b-a>max(abs(a),abs(b))*tol,a<b);
fle <- function(a,b,tol=FTOL) ifelse(is.finite(a) & is.finite(b),b-a>=-max(abs(a),abs(b))*tol,a<=b);
HALFRULE_UP <- 1L; ## round towards +Inf
HALFRULE_DOWN <- 2L; ## round towards -Inf
HALFRULE_IN <- 3L; ## round towards zero
HALFRULE_OUT <- 4L; ## round away from zero
HALFRULE_EVEN <- 5L; ## round to the even multiple of the two multiples of nearest that are tied
HALFRULE_ODD <- 6L; ## round to the odd multiple of the two multiples of nearest that are tied
nearest <- function(x,nearest=1,offset=0,halfrule=HALFRULE_EVEN) {
## ensure correct types
x <- as.double(x);
nearest <- as.double(nearest);
offset <- as.double(offset);
halfrule <- as.integer(halfrule);
## validate
v <- which(!halfrule%in%c(HALFRULE_UP,HALFRULE_DOWN,HALFRULE_IN,HALFRULE_OUT,HALFRULE_EVEN,HALFRULE_ODD)); if (length(v)>0L) stop(paste0('invalid halfrule: ',halfrule[v[1L]],'.'));
## normalize lengths
len <- max(length(x),length(nearest),length(halfrule));
x <- rep(x,len=len);
nearest <- rep(nearest,len=len);
offset <- rep(offset,len=len);
halfrule <- rep(halfrule,len=len);
## apply offset
x <- x-offset;
## must treat zero nearests different from non-zero
nonzero <- fne(nearest,0);
## start building result
res <- double(length(x));
## nearest zero doesn't really make any sense; but you can consider every possible number to be at the nearest zero
res[!nonzero] <- x[!nonzero];
## simplify subsequent operations to only focus on non-zero nearest
x <- x[nonzero];
nearest <- nearest[nonzero];
halfrule <- halfrule[nonzero];
offset <- offset[nonzero];
## don't care about negativity of nearest
nearest <- abs(nearest);
## get how many times nearest goes into x, truncated
mult <- as.integer(x/nearest); ## note: can't use %/%, since that actually floors toward -Inf
## get round-truncated result
r.trunc <- mult*nearest;
## get absolute excess over r.trunc
excess <- abs(x - r.trunc);
## get half of nearest
half.of.nearest <- nearest*0.5;
## add one to mult if necessary; whether we need to do this in the case of a tie depends on the specified tiebreaker rule and which side of the zero multiple x is on
adds <- which(
fgt(excess,half.of.nearest)
| feq(excess,half.of.nearest) & (
halfrule==HALFRULE_UP & fgt(x,0)
| halfrule==HALFRULE_DOWN & flt(x,0)
| halfrule==HALFRULE_OUT
| halfrule==HALFRULE_EVEN & mult%%2L!=0L
| halfrule==HALFRULE_ODD & mult%%2L==0L
)
);
mult[adds] <- mult[adds] + ifelse(flt(x[adds],0),-1,1);
## recover target value from mult, and at the same time unshift offset
res[nonzero] <- nearest*mult+offset;
res;
}; ## end nearest()
nearest.halfup <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_UP );
nearest.halfdown <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_DOWN);
nearest.halfin <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_IN );
nearest.halfout <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_OUT);
nearest.halfeven <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_EVEN);
nearest.halfodd <- function(x,nearest=1,offset=0) nearest(x,nearest,offset,HALFRULE_ODD);
Для примера ввода, нам нужно округлить до ближайшего 0,5 со смещением 0,25:
nearest(seq(1,10,0.33),0.5,0.25);
## [1] 1.25 1.25 1.75 1.75 2.25 2.75 2.75 3.25 3.75 3.75 4.25 4.75 4.75 5.25 5.75 5.75 6.25
## [18] 6.75 6.75 7.25 7.75 7.75 8.25 8.75 8.75 9.25 9.75 9.75
кажется округлить 1,0 до 0,75 в результатах? – thelatemail
Хорошее решение. Кажется, мне нужно определить, где я хочу, чтобы 0.00 и 0.50 пошли. – Phil
Вы также можете рассмотреть выражения типа '0.5 * floor (2.0 * x) + 0.25' и' 0.5 * ceil (2.0 * x) - 0.25', оба из которых округляются до ближайшего 'XXX.25' или' XXX.75 ', но имеют различное поведение в случаях полуцелых краев: первый всегда округляет целые числа и полуцелые значения вверх (т. е., к положительной бесконечности); второй всегда округляет их (к отрицательной бесконечности). –