大家好：我有一个问题与上一篇关于舍入程序的文章有关（此处可用：R：对每行中的内容进行舍入，使行总数等于我指定的数字）。
该程序被设计为对每行中的内容进行四舍五入，使行总数等于我指定的数字。从原始帖子复制而来，这里有一个工作的MWE：
Round <- function(x, target) {
r.x <- round(x)
diff.x <- round(x) - x
if ((s <- sum(r.x)) == target) {
return(r.x)
} else if (s > target) {
select <- seq(along=x)[diff.x > 0]
which <- which.max(diff.x[select])
x[select[which]] <- r.x[select[which]] - 1
Round(x, target)
} else {
select <- seq(along=x)[diff.x < 0]
which <- which.min(diff.x[select])
x[select[which]] <- r.x[select[which]] + 1
Round(x, target)
}
}
dat <- read.table(header = TRUE, row.names = paste0('place', 1:4),
text="race1 race2 total
1.2 2.1 3.4
3.4 3.6 7.0
7.7 0.8 8.5
5.3 1.4 6.7")
totals <- c(4.0, 7.0, 8.0, 7.0)
do.call(rbind, lapply(1:nrow(dat), function(x) Round(dat[x, -3], totals[x])))
# race1 race2
# place1 2 2
# place2 3 4
# place3 7 1
# place4 5 2
问题是：最近我注意到，如果行应该取整到的数字与自然取整的总数相差大于或小于1，则此函数将停止工作。因此，在上述示例中，行2自然地被舍入为3和4。如果totals对象中为第2行指定的总和等于6到8，则该函数工作正常。但是，如果强制行的总数小于6或大于8，则该函数将不再工作。
为了说明这个例子，如果我们按如下方式更改总值，上面的"Round"代码将不再有效：
dat <- read.table(header = TRUE, row.names = paste0('place', 1:4),
text="race1 race2 total
1.2 2.1 3.4
3.4 3.6 7.0
7.7 0.8 8.5
5.3 1.4 6.7")
totals <- c(4.0, 5.0, 8.0, 7.0)
do.call(rbind, lapply(1:nrow(dat), function(x) Round(dat[x, -3], totals[x])))
Error in data.frame(value, row.names=rn, check.names = FALSE, check.rows
= FALSE) : 'row.names' should specify one of the variables
（注意totals对象从c（4.0，7.0，…）到c（4.0、5.0，…）的变化）
我需要帮助的是修改代码，这样，如果强制将行取整到的行总数与自然取整总数相差4，那么特殊的取整函数仍然有效。（在某些情况下，在我更高级的data.frame中，我有一些行需要从自然取整的行总数取整到最多14位。）
更新示例
使用rawr提供的稍微修改过的代码，如果我需要将行取整到的总数与自然取整的总数相差3或更多，我现在会得到一个错误。
更新后的代码如下：
Round <- function(x, target){
r.x <- round(x)
diff.x <- round(x) - x
if ((s <- sum(r.x)) == target) {return(r.x)
} else if (s > target) {
select <- seq(along=x)[diff.x != 0]
which <- which.max(diff.x[select])
x[select[which]] <- r.x[select[which]] - 1
Round(x, target)
}
else{
select <- seq(along=x)[diff.x != 0]
which <- which.min(diff.x[select])
x[select[which]] <- r.x[select[which]] + 1
Round(x, target)
}
}
下面是一个产生错误的例子：
dat <- read.table(header = TRUE, row.names = paste0('district', 1:4),
text="race1 race2 total
1.2 2.1 3.4
3.4 3.6 7.0
7.7 0.8 8.5
5.3 1.4 6.7")
totals <- c(4.0, 5.0, 12.0, 7.0)
do.call(rbind, lapply(1:nrow(dat), function(x) Round(dat[x, -3], totals[x])))
Error in data.frame(value, row.names = rn, check.names = FALSE, check.rows = FALSE) :
'row.names' should specify one of the variables
调试这些错误的最佳方法是处理一些案例并逐步了解函数，以找出错误的来源。
此函数似乎旨在将小数（而非整数）舍入为最接近的整数，因此舍入后，最终所有diff.x != 0都将是FALSE，因此which.max不会返回任何内容。
我想你可以想出很多方法来选择每一步要调整的值，但下面有两种方法，每种方法都有利弊。
第一个简单地取最小值或最大值，这取决于目标是高于还是低于向量的和。第二个随机选择按其值加权的向量元素之一。set.seed使结果可重复，但这在方程中引入了一点随机性。第一个将继续增加或减少相同的值，导致结果偏斜
Round <- function(x, target) {
r.x <- round(x)
diff.x <- r.x - x
if ((s <- sum(r.x)) == target) {
return(r.x)
} else if (s > target) {
select <- seq_along(x)[diff.x != 0]
select <- if (length(select)) select else which.max(x)
wh <- which.max(diff.x[select])
x[select[wh]] <- r.x[select[wh]] - 1
Recall(x, target)
} else {
select <- seq_along(x)[diff.x != 0]
select <- if (length(select)) select else which.min(x)
wh <- which.min(diff.x[select])
x[select[wh]] <- r.x[select[wh]] + 1
Recall(x, target)
}
}
Round2 <- function(x, target) {
set.seed(1)
r.x <- round(x)
diff.x <- r.x - x
if ((s <- sum(r.x)) == target) {
return(r.x)
} else if (s > target) {
select <- seq_along(x)[diff.x != 0]
# select <- if (length(select)) select else which.max(x)
select <- if (length(select)) select else
sample(seq_along(x), 1, prob = prop.table(x))
wh <- which.max(diff.x[select])
x[select[wh]] <- r.x[select[wh]] - 1
Recall(x, target)
} else {
select <- seq_along(x)[diff.x != 0]
# select <- if (length(select)) select else which.min(x)
select <- if (length(select)) select else
sample(seq_along(x), 1, prob = prop.table(x))
wh <- which.min(diff.x[select])
x[select[wh]] <- r.x[select[wh]] + 1
Recall(x, target)
}
}
dat <- read.table(header = TRUE, row.names = paste0('district', 1:4),
text="race1 race2 total
1.2 2.1 3.4
3.4 3.6 7.0
7.7 0.8 8.5
5.3 1.4 6.7")
totals <- c(4.0, 5.0, 12.0, 7.0)
这一个将总是给出相同的结果，但也保持增加与第二个例子中相同的值，其中7.7四舍五入到9，0.8四舍五进到8
cbind(
dat,
totals,
do.call(rbind, lapply(1:nrow(dat), function(x) Round(dat[x, -3], totals[x])))
)
# race1 race2 total totals race1 race2
# district1 1.2 2.1 3.4 4 2 2
# district2 3.4 3.6 7.0 5 2 3
# district3 7.7 0.8 8.5 12 9 3
# district4 5.3 1.4 6.7 7 5 2
cbind(dat[3, ], Round(dat[3, 1:2], 17))
# race1 race2 total race1 race2
# district3 7.7 0.8 8.5 9 8
在这个例子中，我们设置了一个种子，每次都得到相同的结果，但我想采样不太理想，但现在在第二个例子中，7.7四舍五入到15，0.8到2，这更接近我的预期。
cbind(
dat,
totals,
do.call(rbind, lapply(1:nrow(dat), function(x) Round2(dat[x, -3], totals[x])))
)
# race1 race2 total totals race1 race2
# district1 1.2 2.1 3.4 4 2 2
# district2 3.4 3.6 7.0 5 2 3
# district3 7.7 0.8 8.5 12 10 2
# district4 5.3 1.4 6.7 7 5 2
cbind(dat[3, ], Round2(dat[3, 1:2], 17))
# race1 race2 total race1 race2
# district3 7.7 0.8 8.5 15 2