创建在满足条件之前取下一个最大值的while循环函数答案

【问题标题】：Create while loop function that takes next largest value untill condition is met创建在满足条件之前取下一个最大值的while循环函数
【发布时间】：2019-09-16 19:27:47
【问题描述】：

我想创建一个函数，该函数在数据框中创建一个新列，该列以所有行中的所有 0 开头，但将根据以下内容创建 1。它开始查看百分比列中的最高百分比。这将在同一行中新创建的“算法”列中产生 1。然后它将查看起始行的最小和最大行。假设在第 6 行中找到的最高值（起始值）是 13.8%，接下来要查看的行是 5 和 7。然后它将查看此处的百分比并确定最高百分比并在其中创建 1 “算法”列（假设它是第 7 行中的 8.3%）。接下来它将再次查看最小和最大行（第 5 行和第 8 行，因为第 6 行和第 7 行已经考虑在内）。

还有一个重要因素是它必须在一定百分比处停止以寻找更多行，假设在 95% 时它正在停止。这是基于“百分比”列的总百分比，总和应该是 95%。

这是主要思想，但我不知道如何做到这一点。

此外，它最终还必须比最小和最大行看得更远，因为这 2 行也可以都是例如 8%，因此它必须进一步看 1 行并根据最高值选择该行价值。

尚未测试，但这是我目前正在考虑的。

(While(total_perc < p_min_performance)  
prev_row_value <t (minrow -1)
next_rpw_value <t (maxrow +1)

prev > next > t(prev,)  >1
minrow <- minrow-1
maxrow <- maxrow+1

示例代码：

algorithm <- data.frame(pc4 = c(5464),
timeinterval = c('08:45:00', '09:00:00', '09:15:00', '09:30:00', 
'09:45:00', '10:00:00', '10:15:00', '10:30:00', '10:45:00', '11:00:00', 
'11:15:00', '11:30:00'),
stops = c(1, 5, 8, 7, 5, 10, 6, 4, 7, 6, 5, 8)) %>%
mutate(percent = round(stops/sum(stops), digits = 6)*100) %>%
mutate(idgroup = seq_along(timeinterval))

还不确定从哪里开始。编辑：algorithm_clumn 中的 1 也可以是相应的百分比，这可能更容易计算到 95%。

结构应该如下所示（这是一个示例，algorithm_column 中的数据可以是任何基于它在数据中找到的内容）

EDIT:
algorithm
#    pc4 timeinterval stops percent idgroup algorithm_column
#1  5464     08:45:00     1  1.3889       1                0
#2  5464     09:00:00     5  6.9444       2                1
#3  5464     09:15:00     8 11.1111       3                1
#4  5464     09:30:00     7  9.7222       4                1
#5  5464     09:45:00     5  6.9444       5                1
#6  5464     10:00:00    10 13.8889       6                1
#7  5464     10:15:00     6  8.3333       7                1
#8  5464     10:30:00     4  5.5556       8                1
#9  5464     10:45:00     7  9.7222       9                1
#10 5464     11:00:00     6  8.3333      10                1
#11 5464     11:15:00     5  6.9444      11                1
#12 5464     11:30:00     8 11.1111      12                0

Ronak 的代码正在运行：

algorithm$algorithm_column <- 0

output <- do.call(rbind, lapply(split(algorithm, algorithm$pc4), 
function(x) {
     all_index <- x$idgroup
     next_comb <- all_index
     while(sum(x$percent[x$algorithm_column == 1]) <= 95) {
        inds <- next_comb[which.max(x$percent[next_comb])]
        x$algorithm_column[inds] <- 1
        nos <- which(all_index == inds)
         next_comb <- all_index[c(nos - 1, nos + 1)]
        all_index <- setdiff(all_index, inds)
     }
    x
}))

编辑：该函数在某些情况下不起作用，因为当它在下一行中达到两个 0 时，它将占用这些行中的第一个最大值，并且它将在数据集的第一部分中仅找到 0，然后继续下一个最高值。比如这个数据集：

algorithm1 <- data.frame(pc4 = c(8035),
timeinterval = c('03:00:00','03:30:00','04:00:00','04:30:00','05:00:00','05:30:00','06:00:00','06:30:00','07:00:00','07:30:00','08:00:00','08:30:00','09:00:00','09:30:00','10:00:00','10:30:00','11:00:00','11:30:00','12:00:00','12:30:00','13:00:00','13:30:00','14:00:00','14:30:00','15:00:00','15:30:00','16:00:00','16:30:00'),
stops =  c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 70, 0, 6, 0, 0, 0, 3, 0, 3, 3, 0, 5, 0, 0, 0))  %>%
group_by(pc4) %>%
mutate(percent = round(stops/sum(stops), digits = 6)*100) %>%
mutate(idgroup = seq_along(timeinterval)) %>%
mutate(algorithm_column = c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0))

我将迭代添加到函数中以查看顺序，因此您可以看到它首先采用 0。

p_min_performance <- 95         # SET PERCENTAGE!
#Naar 0
algorithm1$algorithm_column <- 0
algorithm1$iteration <- 0
it <- 0
algorithm1 <- do.call(rbind, lapply(split(algorithm1, algorithm1$pc4), 
function(x) {
#Index voor maximum percentage
all_index <- x$idgroup
next_comb <- all_index
#While loop algorithm
while (sum(x$percent[x$algorithm_column == 1]) <= p_min_performance) {
it <- it + 1
inds <- next_comb[which.max(x$percent[next_comb])]
x$algorithm_column[inds] <- 1
x$iteration[inds] <- it
nos <- which(all_index == inds)
next_comb <- all_index[c(nos - 1, nos + 1)]
all_index <- setdiff(all_index, inds)
}
x
}))

输出现在的情况：（时间间隔将从03:00到15:00）

   pc4   tinterval  stops   percen id_g a_col iteration
1   8035    03:00:00    0   0.0000  1   1   14
2   8035    03:30:00    0   0.0000  2   1   13
3   8035    04:00:00    0   0.0000  3   1   12
4   8035    04:30:00    0   0.0000  4   1   11
5   8035    05:00:00    0   0.0000  5   1   10
6   8035    05:30:00    0   0.0000  6   1   9
7   8035    06:00:00    0   0.0000  7   1   8
8   8035    06:30:00    0   0.0000  8   1   7
9   8035    07:00:00    0   0.0000  9   1   6
10  8035    07:30:00    0   0.0000  10  1   5
11  8035    08:00:00    0   0.0000  11  1   4
12  8035    08:30:00    0   0.0000  12  1   3
13  8035    09:00:00    9   9.0909  13  1   2
14  8035    09:30:00    70  70.7071 14  1   1
15  8035    10:00:00    0   0.0000  15  1   15
16  8035    10:30:00    6   6.0606  16  1   16
17  8035    11:00:00    0   0.0000  17  1   17
18  8035    11:30:00    0   0.0000  18  1   18
19  8035    12:00:00    0   0.0000  19  1   19
20  8035    12:30:00    3   3.0303  20  1   20
21  8035    13:00:00    0   0.0000  21  1   21
22  8035    13:30:00    3   3.0303  22  1   22
23  8035    14:00:00    3   3.0303  23  1   23
24  8035    14:30:00    0   0.0000  24  1   24
25  8035    15:00:00    5   5.0505  25  1   25
26  8035    15:30:00    0   0.0000  26  0   0
27  8035    16:00:00    0   0.0000  27  0   0
28  8035    16:30:00    0   0.0000  28  0   0

但这应该是：（时间间隔将从 09:00 到 15:00）

   pc4   tinterval  stops   percen id_g a_col iteration
1   8035    03:00:00    0   0.0000  1   0   0
2   8035    03:30:00    0   0.0000  2   0   0
3   8035    04:00:00    0   0.0000  3   0   0
4   8035    04:30:00    0   0.0000  4   0   0
5   8035    05:00:00    0   0.0000  5   0   0
6   8035    05:30:00    0   0.0000  6   0   0
7   8035    06:00:00    0   0.0000  7   0   0
8   8035    06:30:00    0   0.0000  8   0   0
9   8035    07:00:00    0   0.0000  9   0   0
10  8035    07:30:00    0   0.0000  10  0   0
11  8035    08:00:00    0   0.0000  11  0   0
12  8035    08:30:00    0   0.0000  12  0   0
13  8035    09:00:00    9   9.0909  13  1   2
14  8035    09:30:00    70  70.7071 14  1   1
15  8035    10:00:00    0   0.0000  15  1   3
16  8035    10:30:00    6   6.0606  16  1   4
17  8035    11:00:00    0   0.0000  17  1   5
18  8035    11:30:00    0   0.0000  18  1   6
19  8035    12:00:00    0   0.0000  19  1   7
20  8035    12:30:00    3   3.0303  20  1   8
21  8035    13:00:00    0   0.0000  21  1   9
22  8035    13:30:00    3   3.0303  22  1   10
23  8035    14:00:00    3   3.0303  23  1   11
24  8035    14:30:00    0   0.0000  24  1   12
25  8035    15:00:00    5   5.0505  25  1   13
26  8035    15:30:00    0   0.0000  26  0   0
27  8035    16:00:00    0   0.0000  27  0   0
28  8035    16:30:00    0   0.0000  28  0   0

因此，算法最终应该进一步查看行，然后仅查看最大值旁边的行（如果它们都是 0）。

我现在正忙于创建它的块，但我却卡住了..

runAlgorithm <- function(x, min_performance = 95) {
x$algorithm_column <- 0
x$iteration <- 0

it <- 0

all_index <- x$idgroup
next_comb <- all_index

inds <- next_comb[which.max(x$percent[next_comb])]
x$algorithm_column[inds] <- 1
 x$iteration[inds] <- it

#While loop algorithm
while (sum(x$percent[x$algorithm_column == 1]) <= min_performance) {

prev_values <- x$percent[1:inds - 1]
next_values <- x$percent[inds + 1:length(x$percent)]
first_non_zero_prev <- if_else(sum(prev_values) > 0L, which.max(prev_values 
> 0), NA)
first_non_zero_next <- if_else(sum(next_values) > 0L, which.max(next_values 
> 0), NA)
next_value <- case_when(
  is.na(first_non_zero_prev) & !is.na(first_non_zero_next) ~ next_comb[2],
  !is.na(first_non_zero_prev) & is.na(first_non_zero_next) ~ next_comb[1],
  first_non_zero_prev <= first_non_zero_next ~ next_comb[2],
  first_non_zero_prev > first_non_zero_next ~ next_comb[1]
)

inds <- next_comb[which.max(x$percent[next_value])]
x$algorithm_column[inds] <- 1
x$iteration[inds] <- it

nos <- which(all_index == inds)
next_comb <- all_index[c(nos - 1, nos + 1)]
all_index <- setdiff(all_index, inds)
}
return(x)
}
df_test <- groep_test[1:48,]
output <- runAlgorithm(df_test)

【问题讨论】：

请看图
图片与描述不符。 “然后它将查看此处的百分比并确定最高百分比并在“算法”列中创建一个 1（假设它是第 7 行中的 8.3%）”。这意味着第 5 行将有 0，但在您的图片中为 0。此外，您应该在帖子中提供信息，而不是图片。
图片是我最后想看到的，所以它在图片中总共接近75%（最后应该是95%左右）。它确实与我写的文字不对应，因为过程是这样的。
如果您的描述不匹配，人们如何提供帮助？现在，如果图片是我们唯一可以关注的，答案将是c(0,0,1,1,1,1,1,1,1,1,0,0)。为了有一些匹配的外观，您的图片应该将第 5 行和第 8 行设为 0，因为它们都低于您的最低阈值。
描述是对的，图片只是一个例子，它最终的样子，而不是那些地方的1的样子。最后应该是一串1，中间不能有零。因为我希望最终有一个从 [随机时间] 到 [随机时间] 的时间间隔。例如，图片的时间间隔为 09:15 到 11:00，其中有 63.58% 的观测值（总计 1.11%、9.72%、6.94% 到 8.33%，这是另一列中的 1）

标签： r function loops intervals

【解决方案1】：

这是一种方法。

#Remaining index
all_index <- algorithm$idgroup
#Initialising to 0
algorithm$algorithm_column <- 0
#Index to check for maximum
next_comb <- all_index
#While more than 20% of the rows are remaining.
#Change this to whatever number you wish. For 95% use 0.05 
while(sum(x$percent[x$algorithm_column == 1]) <= 95) {
   #Get maximum index
   inds <- next_comb[which.max(algorithm$percent[next_comb])]
   #Change the value to 1
   algorithm$algorithm_column[inds] <- 1
   nos <- which(all_index == inds)
   #Get the next two indices
   next_comb <- all_index[c(nos - 1, nos + 1)]
   #Remove the previously used index.
   all_index <- setdiff(all_index, inds)
}

由于我们的行数有限，这会在填充 12 行中的 10 行后停止。

algorithm
#    pc4 timeinterval stops percent idgroup algorithm_column
#1  5464     08:45:00     1  1.3889       1                0
#2  5464     09:00:00     5  6.9444       2                1
#3  5464     09:15:00     8 11.1111       3                1
#4  5464     09:30:00     7  9.7222       4                1
#5  5464     09:45:00     5  6.9444       5                1
#6  5464     10:00:00    10 13.8889       6                1
#7  5464     10:15:00     6  8.3333       7                1
#8  5464     10:30:00     4  5.5556       8                1
#9  5464     10:45:00     7  9.7222       9                1
#10 5464     11:00:00     6  8.3333      10                1
#11 5464     11:15:00     5  6.9444      11                1
#12 5464     11:30:00     8 11.1111      12                0

对于多个组，我们可以split基于pc4的数据，并为每个组应用相同的数据。

algorithm$algorithm_column <- 0

 output <- do.call(rbind, lapply(split(algorithm, algorithm$pc4), function(x) {
     all_index <- x$idgroup
     next_comb <- all_index
     while(sum(x$percent[x$algorithm_column == 1]) <= 95) {
        inds <- next_comb[which.max(x$percent[next_comb])]
        x$algorithm_column[inds] <- 1
        nos <- which(all_index == inds)
        next_comb <- all_index[c(nos - 1, nos + 1)]
        all_index <- setdiff(all_index, inds)
    }
    x
}))

【讨论】：

非常感谢您的回答。它看起来像它的工作。虽然，如果我将阈值设置为 0.05 以获得 95% 的准确度，它仍然占用第 1 行，而它已经达到 1.3889% - 100 = 98,6111% 的准确度（结合其余行并查看它们的百分比在“百分比列”中有。你知道为什么吗？
@SaschaS 这里的阈值是什么意思？我只是取1的行数比率。也许你需要在while循环条件中添加sum(algorithm$percent[algorithm$algorithm_column == 1]) <= 95。
感谢工作！但是，如果我有一个完全相同但具有不同 pc4 的数据集（对于每个 pc4，idgroup 仍然从 1 到 12 计数）我该怎么做？所以基本上在第 13 行，这一切都重新开始，但数据不同，比如 pc4 和 5465 分组。
@SaschaS 我已经更新了适用于多个组的答案。可以查一下吗？
循环有效，但在 pc4 组中，我将最小值设置为 95，算法发现行直到 2 行，0% 和 0%（底部，顶部），当仍然有一行8.5%（1 行低于 0%）在这种情况下，它需要 0% 行（不是达到最低 95 行），下一个 8.5% 位于底部，然后所有 0% 行位于顶部。这使我的时间间隔不是从 10:00 到 16:00，而是从 00:00 到 16:00。也许代码不仅应该查看接下来的 2 行，而且如果接下来的两行相同 -> 它会查看旁边的行并选择最高的行。提前谢谢..

【解决方案2】：

这是一个不基于循环的解决方案。基本上，它使用cumsum() 来确定哪些行穿过maximum_threshold。 rowSums(matrix(...)) 组合了您示例中的第 5 行和第 7 行，然后是第 4 行和第 8 行等。

根据您的 cmets，您可以将其添加到 dplyr 链中，包括 group_by()。

f_algo_return <- function(pct, max_threshold = 70){
  # initialize return variable
  algo <- vector(mode = 'integer', length = length(pct))

  #make rows
  max_row <- which.max(pct)

  #if we have odd number of rows, we need to prevent subsetting pct[0]
  len_out <- min(abs(max_row - c(1, length(pct))))

  all_rows <- c(max_row,
                (max_row - len_out):(max_row-1),
                (max_row+1):(max_row + len_out)
  )

  #subset the pct
  pct <- pct[all_rows]

  thresh <- cumsum(c(pct[1], rowSums(matrix(pct[-1], ncol = 2)))) < max_threshold
  sub_rows <- all_rows[c(thresh[1], rev(thresh[-1]), thresh[-1])]

  #initialize and update new variable
  algo[sub_rows] <- 1L

  return(algo)
}

f_algo_return(DF[['percent']])
# [1] 0 0 1 1 1 1 1 1 1 0 0 0

数据：

DF <- data.frame(pc4 = c(5464),
                        timeinterval = c('08:45:00', '09:00:00', '09:15:00', '09:30:00', 
                                         '09:45:00', '10:00:00', '10:15:00', '10:30:00', '10:45:00', '11:00:00', 
                                         '11:15:00', '11:30:00'),
                        stops = c(1, 5, 8, 7, 5, 10, 6, 4, 7, 6, 5, 8)) %>%
  mutate(percent = round(stops/sum(stops), digits = 6)*100) %>%
  mutate(idgroup = seq_along(timeinterval))

【讨论】：