无放回条件抽样下带限制的卵石-桶随机重分配模拟开发问询

Got it, let's work through this constrained pebble-to-bucket reallocation problem. I’m assuming your core constraint is that no pebble can be assigned back to its original bucket (if you had a different specific constraint in mind, feel free to clarify!). Here are two practical solutions depending on whether you need to preserve the original bucket size distribution or not:

Solution 1: Simple per-pebble constrained sampling (no bucket size preservation) #

If you don’t need to keep the number of pebbles in each bucket the same as the original distribution, you can just sample a new bucket for each pebble, excluding its original bucket. This is straightforward and efficient:

set.seed(100)
df1 <- data.frame(pebble = 1:100, bucket = sample(LETTERS[1:10], 100, T), stringsAsFactors = F)

# Add constrained new bucket assignments
set.seed(123) # For reproducibility
df1$new_bucket <- sapply(df1$bucket, function(orig_bucket) {
  # Sample 1 bucket from all buckets except the original
  sample(setdiff(LETTERS[1:10], orig_bucket), 1)
})

# Verify no pebbles stayed in their original bucket
all(df1$bucket != df1$new_bucket)
#> [1] TRUE

Solution 2: Constrained reallocation with preserved bucket sizes #

If you need to keep the exact number of pebbles in each bucket the same as the original (a common "constrained permutation" scenario), we can start with a random matching of the original bucket counts, then fix any conflicts where a pebble ended up in its original bucket:

set.seed(100)
df1 <- data.frame(pebble = 1:100, bucket = sample(LETTERS[1:10], 100, T), stringsAsFactors = F)

# Get original bucket size counts
bucket_counts <- table(df1$bucket)

# Start with a random allocation that matches original bucket sizes
set.seed(456)
df1$new_bucket <- sample(rep(names(bucket_counts), bucket_counts), 100)

# Fix conflicts (pebbles in original bucket)
conflicts <- which(df1$bucket == df1$new_bucket)

while(length(conflicts) > 0) {
  if(length(conflicts) >= 2) {
    # Swap two conflicting pebbles' new buckets to resolve both conflicts
    swap_idx <- sample(conflicts, 2)
    temp <- df1$new_bucket[swap_idx[1]]
    df1$new_bucket[swap_idx[1]] <- df1$new_bucket[swap_idx[2]]
    df1$new_bucket[swap_idx[2]] <- temp
  } else {
    # If only one conflict left, swap with a non-conflicting pebble that won't create a new conflict
    valid_swaps <- which(
      df1$bucket != df1$new_bucket & 
      df1$new_bucket != df1$bucket[conflicts] & 
      df1$bucket != df1$new_bucket[conflicts]
    )
    swap_idx <- sample(valid_swaps, 1)
    temp <- df1$new_bucket[conflicts]
    df1$new_bucket[conflicts] <- df1$new_bucket[swap_idx]
    df1$new_bucket[swap_idx] <- temp
  }
  # Update conflicts list
  conflicts <- which(df1$bucket == df1$new_bucket)
}

# Verify results
all(df1$bucket != df1$new_bucket) # No pebbles in original bucket
#> [1] TRUE
table(df1$new_bucket) == bucket_counts # Bucket sizes match original
#>    A    B    C    D    E    F    G    H    I    J 
#> TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE

Both approaches use conditional sampling without replacement (either per-pebble exclusion, or iterative conflict resolution to enforce the constraint while preserving group sizes).

内容的提问来源于stack exchange，提问作者gfgm