farrow90's questions

我在 R 中有以下矩阵列表：

 my_list =  structure(list(
        matrix(c(2,2,2,2,3, 1,2,2,2,3, 1,2,3,3,3, 1,2,1,3,3, 1,1,1,3,3), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,2,2, 1,1,1,2,2, 1,1,1,3,3, 1,1,3,3,3, 1,1,3,3,3), nrow=5, byrow=TRUE),
        matrix(c(2,2,2,3,3, 2,2,2,3,3, 1,1,3,3,3, 1,1,3,3,3, 1,1,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,3, 2,2,3,3,3, 2,2,2,3,3, 2,2,2,1,1, 1,1,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,3, 1,1,1,2,2, 1,1,1,2,2, 1,1,1,2,2, 1,1,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,3,3, 1,1,1,3,3, 1,1,1,2,2, 1,1,2,2,2, 1,1,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,3,3,2,2, 1,3,3,2,2, 1,1,3,3,2, 1,1,1,3,2, 1,1,1,1,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,2,2, 1,1,1,2,2, 1,1,1,2,3, 1,1,1,2,3, 1,1,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(2,2,2,2,2, 3,3,3,3,3, 3,3,3,3,3, 1,1,3,3,3, 1,1,3,3,3), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,1,1,1,2, 3,1,1,1,2, 3,3,2,2,2, 3,3,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,1,1,1,1, 3,3,1,1,1, 3,3,2,2,1, 2,2,2,1,1, 2,2,2,1,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,3, 3,3,1,3,1, 2,2,1,1,1, 2,2,1,1,1, 2,2,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,1,1,1, 3,1,1,1,1, 3,2,2,1,1, 3,2,2,2,2, 3,3,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,1,1,1,2, 1,1,1,1,2, 3,3,3,2,2, 3,3,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,2, 1,1,1,3,2, 1,3,1,3,2, 1,3,3,3,2, 1,1,3,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,3, 3,3,2,2,2, 3,3,2,2,2, 1,1,2,2,2, 1,1,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,3,3, 1,1,1,3,3, 1,1,2,2,3, 1,1,1,2,3, 1,1,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,3, 1,1,2,3,3, 1,1,2,3,3, 1,1,2,2,2, 1,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,2,2,1,1, 1,1,2,2,1, 3,3,2,2,2, 2,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,1,1, 1,1,1,1,2, 1,1,1,1,2, 1,2,1,2,2, 1,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(2,3,3,3,3, 2,3,3,3,3, 2,3,3,3,3, 2,2,2,1,1, 1,1,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(2,2,2,2,2, 2,2,2,2,2, 2,2,2,2,2, 2,3,1,1,2, 3,3,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,1,1,1,1, 3,1,1,1,1, 2,2,1,1,1, 2,2,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,3,3, 2,1,1,3,3, 2,2,1,1,3, 2,2,2,1,1, 2,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,1,1,1,1, 3,3,3,3,1, 2,2,2,2,1, 2,2,2,2,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,1, 3,3,2,1,1, 3,3,2,1,1, 3,3,2,2,2, 3,3,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,1,1, 3,3,3,1,1, 3,2,2,1,1, 2,2,2,1,1, 2,2,2,1,1), nrow=5, byrow=TRUE),
        matrix(c(2,2,2,1,1, 2,2,2,1,1, 2,2,1,1,1, 3,2,2,1,1, 3,3,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,1,1, 1,2,1,1,1, 1,2,2,1,1, 1,1,2,3,3, 1,1,2,3,3), nrow=5, byrow=TRUE),
        matrix(c(1,1,3,3,3, 1,2,2,2,3, 1,2,2,3,3, 1,2,2,3,3, 1,1,1,3,3), nrow=5, byrow=TRUE),
        matrix(c(3,1,1,1,1, 3,1,1,1,1, 3,3,1,1,2, 3,1,1,2,2, 3,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(1,1,1,3,3, 1,1,1,3,3, 2,3,3,3,3, 2,3,3,2,2, 2,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,2,2,2,2, 3,2,2,2,2, 3,1,2,1,1, 3,1,1,1,1, 3,3,3,3,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,3, 3,3,3,1,1, 2,1,1,1,1, 2,2,2,2,2, 2,2,2,2,2), nrow=5, byrow=TRUE),
        matrix(c(3,3,3,3,2, 3,3,3,3,2, 3,1,1,1,2, 3,1,1,1,1, 3,1,1,1,1), nrow=5, byrow=TRUE),
        matrix(c(3,3,2,2,2, 3,1,1,2,2, 3,1,1,2,2, 1,1,1,2,2, 1,1,1,2,2), nrow=5, byrow=TRUE)
    ), class = "list")

然后我使用以下代码绘制了所有这些图：

library(ggplot2)
library(gridExtra)
library(reshape2)
library(dplyr)

plot_matrix <- function(mat, plot_number) {
    df <- melt(mat)
    names(df) <- c("row", "col", "value")
    
    df$index <- (df$row - 1) * 5 + df$col
    
    colors <- c(
        "1" = "#FFB3B3",
        "2" = "#B3D9FF",
        "3" = "#B3FFB3"
    )
    
    p <- ggplot(df, aes(x = col, y = -row, fill = factor(value))) +
        geom_tile(color = "black", linewidth = 0.5) +
        geom_text(aes(label = index), size = 3) +
        scale_fill_manual(values = colors) +
        labs(title = paste("Object", plot_number)) +
        coord_equal() +
        theme_minimal() +
        theme(
            legend.position = "none",
            plot.title = element_text(hjust = 0.5, margin = margin(b = 10)),
            axis.text = element_blank(),
            axis.title = element_blank(),
            panel.grid = element_blank(),
            plot.margin = margin(5, 5, 5, 5)
        )
    
    return(p)
}

plot_list <- lapply(seq_along(my_list), function(i) {
    plot_matrix(my_list[[i]], i)
})

n_plots <- length(plot_list)
n_cols <- 6
n_rows <- ceiling(n_plots / n_cols)

grid.arrange(
    grobs = plot_list,
    ncol = n_cols,
    nrow = n_rows,
    padding = unit(2, "mm")
)

我有以下问题：如果我们取对象 1 - 我们是否可以做些什么来找出剩余对象中哪一个与对象 1“最相似”，基于：A）颜色分布和 B）颜色边界的形状和 C）颜色边界的位置？

我目前的方法是分别回答这些问题并取平均值。例如：

• A）找出每个物体的颜色分布作为向量，并取物体 1 与所有其他物体之间的欧几里得距离。

• B）和 C）在对象 1 和所有其他对象之间使用类似 Jaccard 距离或 Hausdorf 距离

• 取所有差异的平均值，以了解一般相似性。具有最低平均值的对 (object1, object_i) 最相似

我不确定这种方法有多正确，我想知道是否有更简单的方法。

关于 A 的一个想法）

library(plotly)

color_counts <- data.frame(
    object = 1:length(my_list),
    red = sapply(my_list, function(mat) sum(mat == 1)),
    blue = sapply(my_list, function(mat) sum(mat == 2)),
    green = sapply(my_list, function(mat) sum(mat == 3))
)

point_colors <- ifelse(color_counts$object == 1, "orange", "black")

plot_ly(color_counts, 
        x = ~red, 
        y = ~blue, 
        z = ~green,
        text = ~paste("Object", object),
        type = "scatter3d",
        mode = "markers",
        marker = list(
            color = point_colors,
            size = 6  # Making points slightly larger for better visibility
        )) %>%
    layout(scene = list(
        xaxis = list(title = "Red (1s)"),
        yaxis = list(title = "Blue (2s)"),
        zaxis = list(title = "Green (3s)")
    ))

我编写了这段代码，试图在方格网格上制作出彩色图案，使得对于给定的颜色，该颜色的所有方块都可以到达该颜色的所有其他方块，而不会踩到任何其他颜色。**

首先我制作了网格：

library(igraph)

create_lattice_graph <- function(width, height) {
    coords <- expand.grid(x = 1:width, y = 1:height)
    n_nodes <- nrow(coords)
    
    horizontal_edges <- cbind(1:(n_nodes-1), 2:n_nodes)
    horizontal_edges <- horizontal_edges[horizontal_edges[,1] %% width != 0, ]
    
    vertical_edges <- cbind(1:(n_nodes-width), (width+1):n_nodes)
    
    edges <- rbind(horizontal_edges, vertical_edges)
    g <- make_graph(edges = t(edges), n = n_nodes, directed = FALSE)
    
    return(list(graph = g, layout = as.matrix(coords)))
}

然后，我编写了一个函数来检查颜色选择是否有效：

is_valid_move <- function(position, player, territories, g) {
    neighbors <- neighbors(g, position)
    has_same_territory_neighbor <- any(territories[neighbors] == player)
    return(has_same_territory_neighbor)
}

从这里开始设置颜色（选择一组源节点）：

generate_territories <- function(width, height, source_nodes) {
    lattice <- create_lattice_graph(width, height)
    g <- lattice$graph
    n_nodes <- vcount(g)
    n_players <- length(source_nodes)
    
    territories <- rep(NA, n_nodes)
    
    for(i in 1:n_players) {
        territories[source_nodes[i]] <- i
    }
    
    while(any(is.na(territories))) {
        empty_positions <- which(is.na(territories))
        valid_moves <- list()
        
        for(pos in empty_positions) {
            neighbors <- neighbors(g, pos)
            neighbor_territories <- unique(territories[neighbors])
            neighbor_territories <- neighbor_territories[!is.na(neighbor_territories)]
            
            if(length(neighbor_territories) > 0) {
                for(territory in neighbor_territories) {
                    if(is_valid_move(pos, territory, territories, g)) {
                        valid_moves[[length(valid_moves) + 1]] <- list(
                            position = pos,
                            territory = territory
                        )
                    }
                }
            }
        }
        
        if(length(valid_moves) == 0) break
        
        selected_move <- sample(length(valid_moves), 1)
        position <- valid_moves[[selected_move]]$position
        territory <- valid_moves[[selected_move]]$territory
        territories[position] <- territory
    }
    
    return(territories)
}

最后将结果可视化：

convert_to_color_matrix <- function(territories, width, height) {
    color_matrix <- matrix(".", nrow = height, ncol = width)
    color_map <- c("R", "B", "G", "Y", "P")
    
    for(i in 1:length(territories)) {
        row <- ceiling(i/width)
        col <- ((i-1) %% width) + 1
        color_matrix[row, col] <- color_map[territories[i]]
    }
    
    return(color_matrix)
}

plot_color_matrix <- function(color_matrix, source_nodes = NULL) {
    plot(NULL, xlim = c(0, ncol(color_matrix)), ylim = c(0, nrow(color_matrix)),
         xlab = "", ylab = "", axes = FALSE, asp = 1)
    
    color_map <- c(
        "R" = "#FF6B6B",  # Red
        "B" = "#4DABF7",  # Blue
        "G" = "#69DB7C",  # Green
        "Y" = "#FFD93D",  # Yellow
        "P" = "#DA77F2",  # Purple
        "." = "#F8F9FA"   # Empty
    )
    
    for(i in 1:nrow(color_matrix)) {
        for(j in 1:ncol(color_matrix)) {
            linear_idx <- (i-1)*ncol(color_matrix) + j
            is_source <- linear_idx %in% source_nodes
            
            rect(j-1, nrow(color_matrix)-i, j, nrow(color_matrix)-i+1,
                 col = color_map[color_matrix[i,j]],
                 border = if(is_source) "black" else "gray90",
                 lwd = if(is_source) 2 else 0.5)
            
            # Add node numbers
            text(j-0.5, nrow(color_matrix)-i+0.5, linear_idx,
                 col = "black", cex = 0.4)
        }
    }
}

完整的模拟如下所示：

width <- 10
height <- 10
source_nodes <- c(1, 10, 91, 100, 45) 
territories <- generate_territories(width, height, source_nodes)
color_matrix <- convert_to_color_matrix(territories, width, height)
plot_color_matrix(color_matrix, source_nodes)
title("Territory Simulation")

当我运行多次模拟时，我注意到这个颜色连接规则有时会被违反：

例如，在上面我可以看到有一块红色，后面是紫色，后面是红色......这样一部分红色就与其余的红色隔离开了。

有没有什么办法可以解决这个问题？

谢谢

我在这里看到了这个问题https://math.stackexchange.com/questions/2648895/why-does-fair-random-process-lead-to-unfair-result/5001301#5001301，其中有人对模拟两个玩家随机互相给钱的游戏很感兴趣。

我尝试使用 R 模拟该游戏的多种轨迹，以查看不同指标的分布：

    library(ggplot2)
    library(tidyverse)
    library(gridExtra)
    library(future)
    library(furrr)
    library(parallel)
    
    n_cores <- detectCores() - 1  
    plan(multisession, workers = n_cores)


run_money_simulation <- function(n_sims, n_exchanges, player_a_start, player_b_start) {
    set.seed(123) 
    
    sims_per_core <- ceiling(n_sims / n_cores)
    
    simulate_exchange <- function(n_exchanges, player_a_start, player_b_start) {
        person_a <- numeric(n_exchanges + 1)
        person_b <- numeric(n_exchanges + 1)
        
        person_a[1] <- player_a_start
        person_b[1] <- player_b_start
        
        for(i in 2:(n_exchanges + 1)) {
            change <- sample(c(-1, 1), 1)
            person_a[i] <- person_a[i-1] + change
            person_b[i] <- person_b[i-1] - change
        }
        
        return(list(
            final_diff = person_a[n_exchanges + 1] - person_b[n_exchanges + 1],
            max_diff = max(abs(person_a - person_b)),
            max_amount = max(c(max(person_a), max(person_b))),
            min_amount = min(c(min(person_a), min(person_b)))
        ))
    }
    
    start_time <- Sys.time()
    
    results <- future_map(1:n_sims, function(x) {
        simulate_exchange(n_exchanges, player_a_start, player_b_start)
    }, .options = furrr_options(seed = TRUE))
    
    end_time <- Sys.time()
    time_taken <- difftime(end_time, start_time, units = "secs")
 
    
    final_diffs <- sapply(results, `[[`, "final_diff")
    max_diffs <- sapply(results, `[[`, "max_diff")
    max_amounts <- sapply(results, `[[`, "max_amount")
    min_amounts <- sapply(results, `[[`, "min_amount")
    
    plot_data <- tibble(
        final_diff = final_diffs,
        max_diff = max_diffs,
        max_amount = max_amounts,
        min_amount = min_amounts
    ) %>%
        pivot_longer(everything(), 
                     names_to = "metric", 
                     values_to = "value")
    
    main_plot <- ggplot(plot_data, aes(x = value)) +
        geom_histogram(bins = 50, aes(fill = metric), color = "white", alpha = 0.7) +
        facet_wrap(~metric, scales = "free", ncol = 2) +
        scale_fill_manual(values = c("black", "red", "green4", "purple")) +
        labs(title = paste("Money Exchange Simulation Results\n",
                           "Starting amounts: A =", player_a_start, ", B =", player_b_start),
             subtitle = paste("Number of simulations:", n_sims, 
                              "| Exchanges per simulation:", n_exchanges,
                              "\nProcessed using", n_cores, "CPU cores in", 
                              round(time_taken, 2), "seconds"),
             x = "Value",
             y = "Count") +
        theme_bw() +
        theme(legend.position = "none")
    
    
    print(main_plot)
    
    
    invisible(list(
        final_diffs = final_diffs,
        max_diffs = max_diffs,
        max_amounts = max_amounts,
        min_amounts = min_amounts,
        parameters = list(
            n_sims = n_sims,
            n_exchanges = n_exchanges,
            player_a_start = player_a_start,
            player_b_start = player_b_start,
            n_cores = n_cores,
            processing_time = time_taken
        )
    ))
}

当我调用该函数时：

run_money_simulation(100000, 100, 100, 100)

我得到以下结果：

我只是想知道 - 我可以在 ggplot 中做些什么来检测比例分隔格式，以便删除这些图表中的空白？

我在 R 中有这张图：

library(igraph)

width <- 30
height <- 20
num_nodes <- width * height

x <- rep(1:width, each = height)
y <- rep(1:height, times = width)

g <- make_empty_graph(n = num_nodes, directed = FALSE)

get_node_index <- function(i, j) (i - 1) * height + j

edges <- c()
for(i in 1:width) {
    for(j in 1:height) {
        current_node <- get_node_index(i, j)
        
        if(i < width) edges <- c(edges, current_node, get_node_index(i + 1, j))
        
        if(j < height) edges <- c(edges, current_node, get_node_index(i, j + 1))
    }
}

g <- add_edges(g, edges)

V(g)$x <- x
V(g)$y <- y

par(mfrow=c(1,1))

V(g)$name <- 1:num_nodes
plot(g, vertex.size = 7, vertex.label = V(g)$name, vertex.label.cex = 0.6, main = "Map with         Node Indices")

我想在这个图上选取某个节点，并根据它们与该节点的距离按比例为图上的所有节点着色。也就是说，距离相同的所有节点都具有相同的颜色 - 距离节点较近的节点颜色较深，距离较远的节点颜色较浅。

根据我之前的问题（计算图上多个点之间的最短距离？），我尝试这样做（例如选择节点 50）：

distances_from_50 <- distances(g, v = 50, to = V(g))
max_dist <- max(distances_from_50)

color_palette <- colorRampPalette(c("#08306B", "#F7FBFF"))(max_dist + 1)

V(g)$color <- color_palette[distances_from_50 + 1]

V(g)$color[50] <- "red"

par(mfrow=c(1,1), mar=c(5,4,4,2))
plot(g, 
     vertex.size = 7,
     vertex.label = V(g)$value,
     vertex.label.cex = 0.6,
     main = "Distance-based Color Gradient from Node 50",
     layout = cbind(V(g)$x, V(g)$y))

还有其他方法可以做到让颜色较深的节点仍然具有可见的标签吗？

我在 R 中有一个随机图：

library(igraph)
library(tidyr)

set.seed(123)
g <- sample_gnm(n = 20, m = 20, directed = FALSE)

我正在尝试找出每个节点到每个节点之间的最短距离。

我在 igraph 中找到了一个名为 distances() 的函数并尝试实现它：

dist_df <- as.data.frame(distances(g)) %>%
    mutate(node_i = 1:nrow(.)) %>%
    pivot_longer(cols = -node_i,
                 names_to = "node_j",
                 values_to = "distance") %>%
    mutate(node_j = as.numeric(gsub("V", "", node_j))) %>%
    select(node_i, node_j, distance)

手动检查结果，它们似乎是正确的：

# A tibble: 400 × 3
   node_i node_j distance
    <int>  <dbl>    <dbl>
 1      1      1        0
 2      1      2        2
 3      1      3        3
 4      1      4        4
 5      1      5        4
 6      1      6        3
 7      1      7      Inf
 8      1      8        3
 9      1      9      Inf
10      1     10      Inf

我的问题是： distance() 函数如何能够如此快速地工作？我认为找出图表中的最短路径是一个非常计算密集的过程 - 这个函数如何如此快速地完成它？这是解决此问题的正确函数吗？

我在 R 中有一个马尔可夫链：

set.seed(123)

n_states <- 5

matrix <- matrix(runif(n_states^2), nrow=n_states)

# set some transitions to 0 
matrix[1, 4:5] <- 0 
matrix[5, 1:3] <- 0  
matrix[2, 5] <- 0    

transition_matrix <- t(apply(matrix, 1, function(x) x/sum(x)))

rownames(transition_matrix) <- paste0("S", 1:n_states)
colnames(transition_matrix) <- paste0("S", 1:n_states)

print(round(transition_matrix, 3))

它看起来像这样：

          S1         S2        S3         S4        S5
S1 0.2229340 0.03531601 0.7417500 0.00000000 0.0000000
S2 0.3910569 0.26197885 0.2248868 0.12207747 0.0000000
S3 0.1536622 0.33530265 0.2545791 0.01580275 0.2406533
S4 0.2652280 0.16563210 0.1719994 0.09849610 0.2986444
S5 0.0000000 0.00000000 0.0000000 0.59278229 0.4072177

对于固定的回合数，我想找出所有可能出现的状态序列及其对应的概率。

我尝试使用循环手动枚举所有这样的序列：

# Function to generate sequences for multiple turn lengths
find_sequences_all_turns <- function(transition_matrix, start_state = 1, max_turns = 5) {
    n_states <- nrow(transition_matrix)
    
   
    all_sequences <- list()
    all_probabilities <- numeric()
    all_turns <- numeric()
    seq_counter <- 1
    
    generate_sequence <- function(current_seq, current_prob, steps_left, total_steps) {
        if(length(current_seq) > 1) {
            all_sequences[[seq_counter]] <<- current_seq
            all_probabilities[seq_counter] <<- current_prob
            all_turns[seq_counter] <<- total_steps - steps_left
            seq_counter <<- seq_counter + 1
        }
        
        if(steps_left == 0) {
            return()
        }
        
        current_state <- current_seq[length(current_seq)]
        possible_next_states <- which(transition_matrix[current_state,] > 0)
        
        for(next_state in possible_next_states) {
            prob <- transition_matrix[current_state, next_state]
            generate_sequence(
                c(current_seq, next_state),
                current_prob * prob,
                steps_left - 1,
                total_steps
            )
        }
    }
    
    generate_sequence(c(start_state), 1, max_turns - 1, max_turns)
    
    result_df <- data.frame(
        turn = all_turns,
        sequence_no = 1:length(all_sequences),
        sequence = sapply(all_sequences, paste, collapse=""),
        probability = all_probabilities
    )
    
    result_df <- result_df[order(result_df$turn, -result_df$probability),]
    rownames(result_df) <- NULL
    
    return(result_df)
}

然后我尝试调用该函数：

sequences_df <- find_sequences_all_turns(transition_matrix)

> sequences_df
    turn sequence_no sequence  probability
1      2         154       13 7.417500e-01
2      2           1       11 2.229340e-01
3      2          65       12 3.531601e-02
4      3         171      132 2.487108e-01
5      3         193      133 1.888341e-01
6      3         243      135 1.785046e-01
7      3          40      113 1.653613e-01
8      3         155      131 1.139789e-01
9      3           2      111 4.969955e-02
10     3          66      121 1.381057e-02
11     3         218      134 1.172169e-02
12     3          82      122 9.252048e-03
13     3         104      123 7.942105e-03
14     3          18      112 7.873137e-03
15     3         129      124 4.311289e-03

我可以做些什么来确保此代码在大量回合中运行得更快

PS：我使用此代码来验证每次所有概率的总和是否为 1：

library(dplyr)

probability_sums <- sequences_df %>%
    group_by(turn) %>%
    summarise(
        total_probability = sum(probability),
        num_sequences = n(),
        check_sum_to_one = abs(total_probability - 1) < 1e-10
    )

print(probability_sums)

假设我有一个离散时间马尔可夫链。我感兴趣的是模拟马尔可夫链的多次迭代并观察其平稳分布（即在一段较长的时间内，处于所有状态的时间百分比）。

这是我目前正在使用的 R 代码。

这是马尔可夫链：

library(ggplot2)
library(reshape2)  


transition_matrix <- matrix(c(
    0.7, 0.2, 0.1,  # Probabilities of transitioning from A to A, B, C
    0.3, 0.4, 0.3,  # Probabilities of transitioning from B to A, B, C
    0.2, 0.3, 0.5   # Probabilities of transitioning from C to A, B, C
), nrow = 3, byrow = TRUE)


initial_vector <- c(1/3, 1/3, 1/3)

我尝试按如下方式模拟此过程：

set.seed(123) 
n_simulations <- 1000
states <- numeric(n_simulations)
current_state <- sample(1:3, 1, prob = initial_vector)

for (i in 1:n_simulations) {
    states[i] <- current_state
    current_state <- sample(1:3, 1, prob = transition_matrix[current_state,])
}

state_names <- c("A", "B", "C")
states_letter <- state_names[states]

df <- data.frame(
    time = 1:n_simulations,
    state = states_letter
)

最后，我准备绘图的数据：

cumulative_percentage <- data.frame(
    time = 1:n_simulations,
    A = cumsum(states_letter == "A") / 1:n_simulations * 100,
    B = cumsum(states_letter == "B") / 1:n_simulations * 100,
    C = cumsum(states_letter == "C") / 1:n_simulations * 100
)

cumulative_percentage_melted <- melt(cumulative_percentage, id.vars = "time", 
                                     variable.name = "state", value.name = "percentage")

p2 <- ggplot(cumulative_percentage_melted, aes(x = time, y = percentage, color = state)) +
    geom_line() +
    theme_minimal() +
    labs(title = "Cumulative Percentage of Time Spent in Each State",
         x = "Time Step",
         y = "Cumulative Percentage",
         color = "State") +
    theme(plot.title = element_text(hjust = 0.5)) +
    ylim(0, 100)

p2

state_proportions <- table(states_letter) / n_simulations
print(state_proportions)

有没有办法改变我的代码，这样我就不需要手动定义 A == cumsum、B == cumsum 等等，并对所有状态完成它？

使用 SAS，是否可以使用现有的日期函数和宏来垂直拉伸日历数据框？

例如，我想制作一个包含以下列的数据框：日、月、年。

该表应包含从 1999 年 12 月 1 日到 2005 年 12 月 1 日的所有日期。我可以在 Python 或 Excel 等其他软件中执行此操作 - 但可以在 SAS 中执行此操作吗？

我在 R 的全局环境中有这些数据框：

file_1 <- data.frame(id = 1:5, samplecolumn = letters[1:5], value = rnorm(5))
file_2 <- data.frame(id = 1:5, sample_column = letters[6:10], value = rnorm(5))
file_3 <- data.frame(id = 1:5, othercolumn = letters[11:15], value = rnorm(5))
abc_1 <- data.frame(id = 1:5, samplecolumn = letters[16:20], value = rnorm(5))

对于所有以“file_”开头的数据框，如果有一个名为“samplecolumn”的列，我想将其重命名为“sample_column”。

我认为我可以通过首先识别以“file_”开头的所有数据框，然后重命名它们来做到这一点：

all_objects <- ls()

file_objects <- all_objects[grep("^file_", all_objects)]

for (file in file_objects) {
    df <- get(file)
    
    if ("samplecolumn" %in% colnames(df)) {
        colnames(df)[colnames(df) == "samplecolumn"] <- "sample_column"
        
        assign(file, df)
    }
}

这是在 R 中执行此操作的正确方法吗？

我在 R 中有这些数据框：

abc_1 <- data.frame(col1 = 1:5, col2 = 6:10, col3 = 11:15)
abc_2 <- data.frame(col1 = 21:25, col2 = 26:30, col4 = 31:35)
abc_3 <- data.frame(col1 = 41:45, col2 = 46:50, col5 = 51:55)
def_1 <- data.frame(col1 = 61:65, col2 = 66:70, col6 = 71:75)

对于所有以“abc_”开头的数据框，我想要识别与所有文件共享的列集，然后将它们绑定在一起。

我尝试用很长的方法来做到这一点：

all_objects <- ls()

abc_objects <- all_objects[grep("^abc", all_objects)]

common_cols <- Reduce(intersect, lapply(abc_objects, function(x) colnames(get(x))))

combined_df <- do.call(rbind, lapply(abc_objects, function(x) {
  df <- get(x)
  df[, common_cols, drop = FALSE]
}))

有没有更直接的方法来做到这一点？

我在全局环境中的 R 中有一个数据框：

file_1 <- data.frame(A = 1:5, B = 6:10, C = 11:15)
file_2 <- data.frame(A = 1:5, D = 16:20, E = 21:25)
file_3 <- data.frame(B = 6:10, C = 11:15, F = 26:30)

我想制作一个矩阵来帮助我了解哪些列名在所有数据框中是通用的，哪些不是。

我尝试手动完成此操作：

for (file in files) {
  data <- get(file)
  column_names[[file]] <- colnames(data)
}

all_columns <- unique(unlist(column_names))
matrix <- sapply(column_names, function(cols) all_columns %in% cols)
rownames(matrix) <- all_columns

matrix_df <- as.data.frame(matrix)

print(matrix_df)

这是在 R 中执行此操作的正确方法吗？

顺便说一句，如果它们在列表中，我认为我们可以这样做：

all_columns <- unique(unlist(lapply(mylist, colnames)))

matrix <- sapply(mylist, function(df) all_columns %in% colnames(df))
rownames(matrix) <- all_columns

matrix_df <- as.data.frame(matrix)

print(matrix_df)

我在 R 中有一个数据框，其中有一列（日期格式），其条目如下：2020-04-01

week()我可以使用R 中的函数（使用一月至十二月日历）从每个日期中提取周数（1 到 52） 。

我现在想做同样的事情，但针对财政周，即四月至四月日历。

我尝试了几个选项，但似乎没有快速的方法来实现这一点。有人知道在 R 中是否有标准方法可以做到这一点吗？

这是我正在研究的一个想法草案......

fiscal_week <- function(date) {
  date <- as.Date(date)
  
  fiscal_start <- ymd(paste(year(date) - ifelse(month(date) < 4, 1, 0), "04-01", sep = "-"))
  
  week_num <- as.integer((date - fiscal_start) / 7) + 1
  
  return(week_num)
}

df <- data.frame(Date = as.Date(c("2020-04-01", "2020-05-01", "2020-06-01")))
df$Fiscal_Week <- sapply(df$Date, fiscal_week)
print(df)

我正在使用 R。

我发现这个网站上有关于失业数据的图表：https://www.bls.gov/charts/employment-situation/civilian-unemployment-rate.htm

我正在尝试下载该图表的数据（例如，在 R 中创建数据框）。

我首先尝试Rvest这样做，但似乎我们不允许从该页面抓取数据。

然后我尝试手动复制数据，然后尝试使用cliprr 包访问剪贴板，但格式却完全错误。

最后，我下载了与该图对应的 SVG 文件。我希望 SVG 文件中的某个位置包含该图的底层数据。但在手动检查源代码时，我似乎找不到任何东西。

有人知道是否可以从 SVG 文件访问底层数据吗？

我有以下图表：

library(igraph)
n_rows <- 10
n_cols <- 5
g <- make_lattice(dimvector = c(n_cols, n_rows))

layout <- layout_on_grid(g, width = n_cols)

n_nodes <- vcount(g)
node_colors <- rep("white", n_nodes)

for (row in 0:(n_rows-1)) {
    start_index <- row * n_cols + 1
    node_colors[start_index:(start_index+2)] <- "orange"  
    node_colors[(start_index+3):(start_index+4)] <- "purple"    
}

node_labels <- 1:n_nodes

plot(g, 
     layout = layout, 
     vertex.color = node_colors,
     vertex.label = node_labels,
     vertex.label.color = "black",
     vertex.size = 15,
     edge.color = "gray",
     main = "Rectangular Undirected Network")

在之前的问题（随机将图拆分为小图）中，我学习了如何将该图拆分为 5 个连通的小子图：

library(data.table)

f <- function(g, n) {
  m <- length(g)
  dt <- setDT(as_data_frame(g))
  dt <- rbindlist(list(dt, dt[,.(from = to, to = from)]))
  dt[,group := 0L]
  used <- logical(m)
  s <- sample(m, n)
  used[s] <- TRUE
  m <- m - n
  dt[from %in% s, group := .GRP, from]
  
  while (m) {
    dt2 <- unique(
      dt[group != 0L & !used[to], .(grow = to, onto = group)][sample(.N)],
      by = "grow"
    )
    dt[dt2, on = .(from = grow), group := onto]
    used[dt2[[1]]] <- TRUE
    m <- m - nrow(dt2)
  }
  
  unique(dt[,to := NULL])[,.(vertices = .(from), .N), group]
}

问题：假设我运行此函数 25 次并存储

generate_multiple_subgraphs <- function(n_iterations = 25, n_rows = 10, n_cols = 5, n_subgraphs = 5) {
    g <- make_lattice(dimvector = c(n_cols, n_rows))
    
    subgraph_list <- lapply(1:n_iterations, function(i) {
        f(g, n_subgraphs)
    })
    
    return(subgraph_list)
}
subgraph_sets <- generate_multiple_subgraphs()

在每个子图中，我想计算每个分区中紫色节点（相对于原始颜色，即开始时为紫橙色的图）的百分比。

我能够得到原始图表的摘要：

original_node_data <- data.frame(
    Node = 1:n_nodes,
    Color = node_colors
)

但我不确定如何将此数据框合并到子图列表中以获得如下结果：

   subgraph partition total_nodes purple_nodes percent_purple
        <int>     <int>       <int>        <int>          <num>
  1:        1         1          14            8       57.14286
  2:        1         2          12            2       16.66667
  3:        1         3           4            0        0.00000
  4:        1         4           9            6       66.66667
  5:        1         5          11            4       36.36364
 ---                                                           
121:       25         1          13            3       23.00000
122:       25         2           6            6      100.00000
123:       25         3           9            0        0.00000
124:       25         4           8            5       62.50000
125:       25         5          14            6       42.00000

有人可以告诉我怎么做吗？

我在 R 中有这个图形网络：

library(igraph)
n_rows <- 10
n_cols <- 5
g <- make_lattice(dimvector = c(n_cols, n_rows))

layout <- layout_on_grid(g, width = n_cols)

n_nodes <- vcount(g)
node_colors <- rep("white", n_nodes)

for (row in 0:(n_rows-1)) {
    start_index <- row * n_cols + 1
    node_colors[start_index:(start_index+2)] <- "orange"  
    node_colors[(start_index+3):(start_index+4)] <- "purple"    
}

node_labels <- 1:n_nodes

plot(g, 
     layout = layout, 
     vertex.color = node_colors,
     vertex.label = node_labels,
     vertex.label.color = "black",
     vertex.size = 15,
     edge.color = "gray",
     main = "Rectangular Undirected Network")

我正在尝试编写一个函数，将该网络随机分成 5 个连通的子图（即迷你图），使得每个节点恰好出现一次。

我认为从理论上讲，这应该不太难。我需要随机识别一个节点，随机决定要包含多少个邻居，选择这些邻居并将它们从图中删除……然后在剩余的图上重新启动此过程。当然，需要指定一些其他细节，例如，如果指定的随机数超过剩余节点的数量，则使用最大函数，需要使用 BFS 来选择节点，等等。

这是我第一次尝试编写代码：

get_connected_subgraph <- function(graph, available_nodes, min_nodes = 5, max_nodes = 15) {
    if (length(available_nodes) == 0) return(NULL)
    
    start_node <- sample(available_nodes, 1)
    
    bfs_result <- bfs(graph, root = start_node, unreachable = FALSE, order = TRUE, rank = TRUE, father = TRUE)
    
    bfs_order <- intersect(bfs_result$order, available_nodes)
    
    n_subgraph_nodes <- min(sample(min_nodes:max_nodes, 1), length(bfs_order))
    
    subgraph_nodes <- bfs_order[1:n_subgraph_nodes]
    
    return(subgraph_nodes)
}

create_5_subgraphs <- function(graph) {
    available_nodes <- V(graph)
    subgraphs <- list()
    
    for (i in 1:5) {
        subgraph_nodes <- get_connected_subgraph(graph, available_nodes)
        if (is.null(subgraph_nodes)) break
        
        subgraphs[[i]] <- subgraph_nodes
        available_nodes <- setdiff(available_nodes, subgraph_nodes)
    }
    
    return(subgraphs)
}

set.seed(42) 
subgraphs <- create_5_subgraphs(g)

subgraph_colors <- c("red", "blue", "green", "yellow", "purple")

node_subgraph_colors <- rep("lightgray", vcount(g))
for (i in 1:length(subgraphs)) {
    node_subgraph_colors[subgraphs[[i]]] <- subgraph_colors[i]
}

edge_subgraph_colors <- rep("lightgray", ecount(g))
for (i in 1:length(subgraphs)) {
    subgraph_edges <- E(g)[.inc(subgraphs[[i]])]
    edge_subgraph_colors[subgraph_edges] <- subgraph_colors[i]
}

plot(g, 
     layout = layout,
     vertex.color = node_subgraph_colors,
     vertex.label = node_labels,
     vertex.label.color = "black",
     vertex.size = 15,
     edge.color = edge_subgraph_colors,
     edge.width = 2,
     main = "Network with 5 Separate Connected Subgraphs")

上述结果看起来几乎正确，但黄色节点（例如 29）似乎违反了连通性。

关于如何修复此问题有什么指示吗？

我编写了一些可选代码来比较前后情况：

node_info <- data.frame(
    Node_Index = 1:vcount(g),
    Original_Color = node_colors,
    New_Color = node_subgraph_colors
)

get_subgraph_number <- function(node) {
    subgraph_num <- which(sapply(subgraphs, function(x) node %in% x))
    if (length(subgraph_num) == 0) return(NA)
    return(subgraph_num)
}

node_info$Subgraph_Number <- sapply(node_info$Node_Index, get_subgraph_number)

head(node_info)

为了补充 jblood94 的惊人答案，这里有一个与 jblood94 的答案一起使用的快速绘图功能：

library(igraph)
library(data.table)

f <- function(g, n) {
    m <- length(g)
    dt <- setDT(as_data_frame(g))
    dt <- rbindlist(list(dt, dt[,.(from = to, to = from)]))
    dt[,group := 0L]
    used <- logical(m)
    s <- sample(m, n)
    used[s] <- TRUE
    m <- m - n
    dt[from %in% s, group := .GRP, from]
    
    while (m) {
        dt2 <- unique(
            dt[group != 0L & !used[to], .(grow = to, onto = group)][sample(.N)],
            by = "grow"
        )
        dt[dt2, on = .(from = grow), group := onto]
        used[dt2[[1]]] <- TRUE
        m <- m - nrow(dt2)
    }
    
    unique(dt[,to := NULL])[,.(vertices = .(from)), group]
}


plot_multiple_subgraphs <- function(n_plots = 25, n_rows = 10, n_cols = 5, n_subgraphs = 5) {
    g <- make_lattice(dimvector = c(n_cols, n_rows))
    layout <- layout_on_grid(g, width = n_cols)
    n_nodes <- vcount(g)
    
    color_palette <- c("red", "blue", "green", "yellow", "purple")
    
    par(mfrow = c(5, 5), mar = c(0.5, 0.5, 2, 0.5))
    
    for (i in 1:n_plots) {
        subgraphs <- f(g, n_subgraphs)
        
        node_colors <- rep("white", n_nodes)
        
        for (j in 1:nrow(subgraphs)) {
            nodes <- unlist(subgraphs$vertices[j])
            node_colors[nodes] <- color_palette[j]
        }
        
        plot(g, 
             layout = layout, 
             vertex.color = node_colors,
             vertex.label = NA,  
             vertex.size = 15,   
             edge.color = "gray",
             edge.width = 0.5,  
             main = paste("Partition", i),  
             cex.main = 0.8)     
    }
}

plot_multiple_subgraphs()

在这个问题（网络中的节点总和）中，我学习了如何在原始网络中找到具有最大节点总和的平方。

以下是该问题的数据：

library(igraph)

width <- 30
height <- 20
num_nodes <- width * height

# Create a grid
x <- rep(1:width, each = height)
y <- rep(1:height, times = width)

g <- make_empty_graph(n = num_nodes, directed = FALSE)

# Function to get node index
get_node_index <- function(i, j) (i - 1) * height + j

# Add edges
edges <- c()
for(i in 1:width) {
   for(j in 1:height) {
      current_node <- get_node_index(i, j)
    
      # Connect to right neighbor
      if(i < width) edges <- c(edges, current_node, get_node_index(i + 1, j))
    
      # Connect to bottom neighbor
      if(j < height) edges <- c(edges, current_node, get_node_index(i, j + 1))
   }
}

g <- add_edges(g, edges)

V(g)$x <- x
V(g)$y <- y

par(mfrow=c(1,2))

V(g)$name <- 1:num_nodes
plot(g, vertex.size = 7, vertex.label = V(g)$name, vertex.label.cex = 0.6, main = "Map with         Node Indices")

V(g)$value <- sample(1:100, num_nodes, replace = TRUE)
plot(g, vertex.size = 7, vertex.label = V(g)$value, vertex.label.cex = 0.6, main = "Map with     Population Values")

该函数如下：

sg <- subgraph_isomorphisms(make_ring(4), g)
lst <- unique(lapply(sg, \(x) sort(names(x))))
out <- do.call(
  rbind,
  lapply(
    lst,
    \(v) data.frame(
      node_id = toString(v),
      value = sum(V(induced_subgraph(g, v))$value)
    )
  )
)

这种方法目前采用的是强力方法，即对每个节点进行单独检查。R中是否有任何方法可以重构此函数，使其并行运行，或者使用不同类型的搜索算法来更有效地扫描网络？

我对此有两个想法：

1. 想法1：

   重写函数来查看方形网格并通过网络对其进行镶嵌：

    efficient_sum_squares <- function(g, width, height) {
      results <- data.frame(node_id = character(), value = numeric())
   
      for (i in 1:(width - 1)) {
        for (j in 1:(height - 1)) {
          nodes <- c(
            get_node_index(i, j),
            get_node_index(i + 1, j),
            get_node_index(i, j + 1),
            get_node_index(i + 1, j + 1)
          )
   
          sum_value <- sum(V(g)$value[nodes])
   
          results <- rbind(results, data.frame(node_id = toString(nodes), value = sum_value))
        }
      }
   
      results
    }
   
    out_efficient <- efficient_sum_squares(g, width, height)
   

2. 想法2：

   我认为比较可以以矢量化的方式进行：

    vectorized_sum_squares <- function(g, width, height) {
      x_mat <- matrix(V(g)$x, nrow = height, ncol = width, byrow = FALSE)
      y_mat <- matrix(V(g)$y, nrow = height, ncol = width, byrow = FALSE)
      value_mat <- matrix(V(g)$value, nrow = height, ncol = width, byrow = FALSE)
   
      sums <- value_mat[1:(height-1), 1:(width-1)] + 
              value_mat[2:height, 1:(width-1)] + 
              value_mat[1:(height-1), 2:width] + 
              value_mat[2:height, 2:width]
   
      node_ids <- apply(which(sums == sums, arr.ind = TRUE), 1, function(idx) {
        i <- idx[1]
        j <- idx[2]
        toString(c(
          get_node_index(j, i),
          get_node_index(j + 1, i),
          get_node_index(j, i + 1),
          get_node_index(j + 1, i + 1)
        ))
      })
   
      data.frame(node_id = node_ids, value = as.vector(sums))
    }
   
    out_vectorized <- vectorized_sum_squares(g, width, height)
   

有没有更好的方法来解决此问题？

假设有一家医院诊所，其中有一份每天有多少患者到医院就诊的清单。我有 10 年的数据 - 但患者并非每天都到诊所就诊。举个例子，数据如下所示（在 R 中）：

library(dplyr)

set.seed(123)

start_date <- as.Date("2010-01-01")
end_date <- as.Date("2019-12-31")
all_dates <- seq.Date(start_date, end_date, by="day")

num_visits <- sample(1:length(all_dates), size = 3000, replace = FALSE)
visit_dates <- all_dates[num_visits]

num_patients <- sample(1:100, size = length(visit_dates), replace = TRUE)

clinic_data <- data.frame(date = visit_dates, num_patients = num_patients)

hospital_data <- clinic_data %>% arrange(date)

       date num_patients
 2010-01-01           90
 2010-01-02           96
 2010-01-04           65
 2010-01-05           80
 2010-01-06           15
 2010-01-07           87

我想尝试回答以下问题： 平均而言 - 对于任何给定的月份，该月所有患者中有多少百分比会在 $y$ 天之前到访过诊所？例如，假设我知道在某个月份有 900 人到访过医院 - 我想知道到 19 日为止，根据之前的趋势，这 900 人中有多少百分比（累计）可能在那时之前到访过医院？

我尝试通过手动识别不同的逻辑步骤来做到这一点：

library(ggplot2)

hospital_data$year <- as.numeric(format(as.Date(hospital_data$date), "%Y"))
hospital_data$month <- as.numeric(format(as.Date(hospital_data$date), "%m"))
hospital_data$day <- as.numeric(format(as.Date(hospital_data$date), "%d"))

hospital_data <- hospital_data[order(hospital_data$date), ]

yearly_totals <- aggregate(num_patients ~ year, data = hospital_data, FUN = sum)
names(yearly_totals)[2] <- "yearly_total"

hospital_data <- merge(hospital_data, yearly_totals, by = "year")

results <- by(hospital_data, hospital_data$year, function(df) {
    df$cumulative_patients <- cumsum(df$num_patients)
    df$cumulative_percentage <- df$cumulative_patients / df$yearly_total * 100
    return(df)
})
results <- do.call(rbind, results)

avg_results <- aggregate(cumulative_percentage ~ day, data = results, FUN = mean, na.rm = TRUE)

avg_results <- avg_results[order(avg_results$day), ]

ggplot(avg_results, aes(x = day, y = cumulative_percentage)) +
    geom_line() +
    geom_point() +
    scale_x_continuous(breaks = seq(1, 31, by = 5)) +
    scale_y_continuous(limits = c(0, 100)) +
    labs(title = "Average Cumulative Percentage of Yearly Patients by Day",
         x = "Day of Month",
         y = "Average Cumulative Percentage of Patients") +
    theme_minimal() +
    theme(panel.grid.minor = element_blank())

但我的图表没有显示这个累积百分比：

有人知道我把事情搞砸了吗？

编辑：

library(tidyverse)

result <- hospital_data %>%
  mutate(month = floor_date(date, "month"),
         day = day(date)) %>%
  group_by(month) %>%
  arrange(month, day) %>%
  mutate(month_total = sum(num_patients),
         cuml = cumsum(num_patients),
         cuml_pct = cuml / month_total) %>%
  ungroup() %>%
  group_by(day) %>%
  summarize(avg_cuml_pct = mean(cuml_pct, na.rm = TRUE)) %>%
  arrange(day)

result <- result %>%
  mutate(avg_cuml_pct = cummax(avg_cuml_pct))

ggplot(result, aes(day, avg_cuml_pct)) +
  geom_line() +
  scale_y_continuous(labels = scales::percent_format(), limits = c(0, 1)) +
  scale_x_continuous(breaks = seq(0, 31, by = 5)) +
  labs(x = "Day of Month", 
       y = "Average Cumulative Percentage of Monthly Patients",
       title = "Average Cumulative Patient Percentage by Day of Month") +
  theme_minimal()

我有这个数据集：

set.seed(123)  
old <- data.frame(matrix(sample(c(1:10, NA), 35, replace = TRUE), ncol = 7, nrow = 5))

在每一行中，我想找到前 5 个非 NA 值并将它们放入新的数据框中。

我考虑过如何使用以下函数来实现这一点：

extract_non_na <- function(row) {
    non_na_values <- na.omit(row)
    if (length(non_na_values) < 5) {
        non_na_values <- c(non_na_values, rep(NA, 5 - length(non_na_values)))
    }
    return(non_na_values[1:5])
}

现在的问题是如何在 R 中的行间应用此函数。我研究了这个问题，显然这是用 t 完成的？

new <- t(apply(old, 1, extract_non_na))

这是正确的协议吗？

我有一个数据框：

mydf <- data.frame(
  col1 = c("54", "abc", "123", "54 abc", "zzz", "a", "99"),
  col2 = c("100", "200", "300", "400", "500", "600", "700"),
  stringsAsFactors = FALSE
)

在此数据框中，我想用 NA 替换所有元素，除非它们满足以下条件之一：

• 严格来说是一个数字（例如“54”保留，“54 abc”丢弃）
• 属于 target_string

我不确定如何使用 apply 在 R 中执行此操作，因此我尝试编写一个循环：

target_string <- c("a", "zzz")

replace_with_na_old <- function(df, target_string) {
  for (i in 1:nrow(df)) {
    for (j in 1:ncol(df)) {
      value <- df[i, j]
      if (!grepl("^[0-9]+$", value) && !(value %in% target_string)) {
        df[i, j] <- NA
      }
    }
  }
  return(df)
}

mydf_cleaned_old <- replace_with_na_old(mydf, target_string)

还有其他方法可以做到这一点吗？

注意：以下是如何用 %like% 替换 %in%：

   replace_with_na_new <- function(df, target_string) {
  for (i in 1:nrow(df)) {
    for (j in 1:ncol(df)) {
      value <- df[i, j]
      if (!grepl("^[0-9]+$", value) && !any(sapply(target_string, function(pattern) grepl(pattern, value)))) {
        df[i, j] <- NA
      }
    }
  }
  return(df)
}