根据偏好组合样本中的数字 回复评论

如何解决根据偏好组合样本中的数字 回复评论

所以我正在为棋盘游戏编写一个函数，我有以下示例“Rolls”：

Rolls <- sample(1:6,6,replace = TRUE)

我想要的是让我的样本优先考虑某些数字（如果这有意义的话），基本上，假设我想要从样本中获得尽可能多的 4。我的选择是保留所有的 4 点，并将成对的点数相加以产生更多的 4。我可能没有很好地解释它，所以这里是一个例子：

假设我掷出 3 4 2 1 1 1，我有一个 4 想要保留（所以我只留下它）但我也看到我有一个 3 和 1，我可以从样本中取出并添加一起制作另一个 4，所以我希望我的代码能够做到这一点，我希望它制作尽可能多的 4。我还有一个 2 和两个 1 剩下的可以变成 4，但是，我不能将 2 个以上的数字加在一起，所以不应该这样做。最后我的新样本应该是这样的：4 2 1 1 4（数字的位置无关）

我希望我已经设法很好地解释了我的场景，以便理解，如果需要任何说明，我可以提供。

提前致谢

解决方法

以下似乎有效。我试着用解释性的名称和每一步来编写函数，以不难理解它在做什么。

主要思想是使用内置 {utils} 中的 combn() 来获取具有“合并”可能组合的数据框。

从可能的组合来看，我们只能合并 1 个骰子一次。 （如果您已经合并了第 1 个和第 3 个，则应该无法合并第 3 个和第 4 个，因为第 3 个已经被使用）。此步骤在 get_vec_of_dice_to_remove 中完成。然后最后我们每 2 个骰子替换一个合并目标。

我确信有更好、更有效的方法来做，但我无法编写。还有其他方法的步骤（调用）要少得多，但我更愿意让它更明确，以便您可以了解正在发生的事情，如果您希望可以改进，请删除一些不必要的步骤或调整您喜欢的方式。

（提示：如果您想一步一步地了解函数内部发生的事情，请在下次运行该函数时使用 debugonce(merge_dice_matching_nr) 输入 debug mode。在调试模式下，您可以缓慢地浏览函数，并在函数内部检查每个对象。）

library(dplyr)

roll_dice <- function(nr_of_dice = 6) {
  sample(1:6,nr_of_dice,replace = TRUE)
}

get_data_frame_of_possible_combs <- function(throw,merging) {
  
  possible_combinations <- t(combn(throw,2))
  sums_possible_combinations <- rowSums(possible_combinations)
  posit <- t(combn(x=1:length(throw),2))
  df_res <- data.frame(possible_combinations,sums_possible_combinations,match = (sums_possible_combinations == merging),posit) %>% 
    filter(match == TRUE)
  
  names(df_res) <- c("die_1","die_2","sums_possible","match","pos_d1","pos_d2")
  return(df_res)
}

get_vec_of_dice_to_remove <- function(df) {
  vec_of_dice <- c()
  for (i in 1:nrow(df)) {
    row_of_df <- slice(df,1)
    dice <- c(row_of_df$pos_d1,row_of_df$pos_d2)
    df <- df %>% filter( !(pos_d1 %in% dice | pos_d2 %in% dice) )
    
    vec_of_dice <- append(vec_of_dice,dice)
    
    if (nrow(df)==0) { break }
  }  
  return(vec_of_dice)
}


merge_dice_matching_nr <- function(throw,merging,merged_results_only=FALSE) {
  
  
  df_res <- get_data_frame_of_possible_combs(throw = throw,merging = merging)
  
  vec_to_remove <- get_vec_of_dice_to_remove(df_res)
  
  
  if (length(vec_to_remove)>0) {
    # if there is nothing to merge,return  results_merged as the original throw
    res_merged <- append(throw[-vec_to_remove],rep(merging,length(vec_to_remove)/2))  
  } else {
    res_merged <- throw
  }
  
  if (merged_results_only) {
    return(c(res_merged))
  }
  ret_list <- list("orignial_throw" = throw,"dice_posit_to_remove" = vec_to_remove,"results_merged" = res_merged)
  
  return(ret_list)
}


set.seed(2)
(roll <- roll_dice()) %>% 
  merge_dice_matching_nr(merging = 2)
#> $orignial_throw
#> [1] 5 6 6 1 5 1
#> 
#> $dice_posit_to_remove
#> [1] 4 6
#> 
#> $results_merged
#> [1] 5 6 6 5 2



roll %>%  
  merge_dice_matching_nr(merging = 2,merged_results_only = T) %>%  
  merge_dice_matching_nr(merging = 12,merged_results_only = T) %>% 
  merge_dice_matching_nr(merging = 10,merged_results_only = T) %>% 
  merge_dice_matching_nr(merging = 12,merged_results_only = T) %>% 
  merge_dice_matching_nr(merging = 24,merged_results_only = T)
#> [1] 24


set.seed(2)
(roll <- roll_dice() )
#> [1] 5 6 6 1 5 1

roll %>% merge_dice_matching_nr(merging = 2)
#> $orignial_throw
#> [1] 5 6 6 1 5 1
#> 
#> $dice_posit_to_remove
#> [1] 4 6
#> 
#> $results_merged
#> [1] 5 6 6 5 2
roll %>% merge_dice_matching_nr(merging = 5)
#> $orignial_throw
#> [1] 5 6 6 1 5 1
#> 
#> $dice_posit_to_remove
#> integer(0)
#> 
#> $results_merged
#> numeric(0)
roll %>% merge_dice_matching_nr(merging = 6)
#> $orignial_throw
#> [1] 5 6 6 1 5 1
#> 
#> $dice_posit_to_remove
#> [1] 1 4 5 6
#> 
#> $results_merged
#> [1] 6 6 6 6

另一种允许数字向量参数的实现

这是另一种允许数字向量输入的选项，以便一次处理一个项目。

merge_dice_matching_nr <- function(throw,merged_results_only=FALSE) {
  
  i_throw <- throw
  for (i in 1:length(merging)) {
    i_merging <- merging[i]
    df_res <- get_data_frame_of_possible_combs(throw = i_throw,merging = i_merging)
    
    vec_to_remove <- get_vec_of_dice_to_remove(df_res)
    
    
    if (length(vec_to_remove)>0) {
      # if there is nothing to merge,return  results_merged as the original throw
      res_merged <- append(i_throw[-vec_to_remove],rep(i_merging,length(vec_to_remove)/2))  
    } else {
      res_merged <- i_throw
    }
    i_throw <- res_merged
  } 
  
  if (merged_results_only) {
    return(c(res_merged))
  }
  ret_list <- list("original_throw" = throw,"results_merged" = res_merged)
  
  return(ret_list)
}


set.seed(2)
(roll <- roll_dice()) %>% 
  merge_dice_matching_nr(merging = 2)

roll %>% 
  merge_dice_matching_nr(merging = c(2,12,10,24))

# $original_throw
# [1] 5 6 6 1 5 1

# $dice_posit_to_remove
# [1] 1 2

# $results_merged
# [1] 24

其他两个功能保持不变。

回复评论

这应该有效

set.seed(1212)
Rolls <- roll_dice()

Rolls
# [1] 2 1 5 4 6 4
Rolls <- Rolls %>% merge_dice_matching_nr(merging = 6,merged_results_only = T)
Rolls
# [1] 6 4 6 6
Rolls <- Rolls %>% merge_dice_matching_nr(5,merged_results_only = T)
Rolls
# [1] 6 4 6 6