farrow90's questions

Tenho esta lista de matrizes em 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")

Em seguida, tracei todos eles usando o seguinte código:

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")
)

Tenho a seguinte pergunta: se pegarmos o objeto 1, há algo que podemos fazer para descobrir qual dos objetos restantes é "mais semelhante" ao objeto 1 com base em: A) distribuição de cores E B) formato dos limites de cores E C) posicionamento dos limites de cores?

Minha abordagem atual é responder cada uma dessas perguntas separadamente e tirar a média delas. Por exemplo:

• A) Descubra a distribuição de cores de cada objeto como um vetor e calcule a distância euclidiana entre o objeto 1 e todos os outros objetos.

• B) e C) Use algo como Distância de Jaccard ou Distância de Hausdorf entre o objeto 1 e todos os outros objetos

• pegue a média de todas as diferenças para ter uma ideia da similaridade geral. O par (objeto1, objeto_i) com a média mais baixa é o mais similar

Não tenho certeza se essa abordagem é correta e queria saber se há algo mais fácil.

Uma ideia para 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)")
    ))

Eu escrevi este código que tenta criar padrões coloridos em uma grade quadrada de modo que, para uma determinada cor, todos os quadrados daquela cor possam alcançar todos os outros quadrados daquela cor sem pisar em nenhuma outra cor.**

Primeiro fiz a grade:

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)))
}

Então, escrevi uma função que verifica se uma escolha de cor é válida:

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)
}

A partir daqui, a cor é definida (um conjunto de nós de origem são escolhidos):

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)
}

Por fim, os resultados são visualizados:

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)
        }
    }
}

A simulação completa se parece com isso:

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")

Quando executei várias simulações, percebi que essa regra de conectividade de cores às vezes é violada:

Por exemplo, acima posso ver que há um bloco vermelho, seguido de roxo, seguido de vermelho... de modo que parte do vermelho está bloqueada do resto do vermelho.

Existe alguma maneira de resolver esse problema?

Obrigado

Me deparei com esta pergunta aqui https://math.stackexchange.com/questions/2648895/why-does-fair-random-process-lead-to-unfair-result/5001301#5001301 na qual alguém estava interessado em simular um jogo em que dois jogadores dão dinheiro um ao outro aleatoriamente.

Usando R, tentei simular múltiplas trajetórias deste jogo para observar as distribuições de diferentes métricas:

    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
        )
    ))
}

Quando eu chamo a função:

run_money_simulation(100000, 100, 100, 100)

Obtenho os seguintes resultados:

Só estou pensando: há algo que eu possa fazer no ggplot que detecte um formato de quebra de escala de modo que os espaços em branco nesses gráficos sejam removidos?

Eu tenho este gráfico em 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")

Quero escolher algum nó neste gráfico e colorir todos os nós neste gráfico proporcionalmente à distância que eles estão localizados deste nó. Ou seja, todos os nós da mesma distância têm a mesma cor - e os nós mais próximos do nó são mais escuros, enquanto os nós mais distantes são mais claros.

Com base na minha pergunta anterior ( Calculando a menor distância entre vários pontos em um gráfico? ), tentei fazer isso (por exemplo, selecionar o nó 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))

Existe algo mais que pode ser feito para que os nós com cores mais escuras ainda tenham rótulos visíveis?

Tenho um gráfico aleatório em R:

library(igraph)
library(tidyr)

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

Estou tentando descobrir a menor distância entre cada nó.

Encontrei esta função no igraph chamada distances() e tentei implementá-la:

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)

Verificando manualmente os resultados, eles parecem estar corretos:

# 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

Aqui está minha pergunta: Como a função distance() consegue funcionar tão rápido? Eu pensei que descobrir o caminho mais curto em gráficos é um processo computacionalmente intensivo - como essa função faz isso tão rápido? Essa é a função correta para esse problema?

Tenho uma Cadeia de Markov em 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))

Parece algo assim:

          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

Para um número fixo de voltas, quero descobrir todas as sequências de estados possíveis que podem ocorrer e suas probabilidades correspondentes.

Tentei fazer isso manualmente usando loops para enumerar todas essas sequências:

# 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)
}

Então tentei chamar a função:

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

Existe algo que eu possa fazer para garantir que esse código seja executado mais rápido para um grande número de voltas

PS: Usei esse código para verificar se todas as probabilidades somam 1 em cada turno:

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)

Suponha que eu tenha uma cadeia de Markov de tempo discreto. Estou interessado em simular a Cadeia de Markov em múltiplas iterações e observar a distribuição estacionária (ou seja, em um longo período de tempo, porcentagem de tempo gasto em todos os estados).

Este é o código R que estou usando atualmente.

Aqui está a Cadeia de Markov:

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)

Tentei simular isso da seguinte maneira:

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
)

Por fim, preparo os dados para plotagem:

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)

Existe uma maneira de alterar meu código para que eu não precise definir manualmente A == cumsum, B == cumsum etc etc e fazer isso para todos os estados?

Usando o SAS, é possível usar funções de data e macros existentes para esticar verticalmente um quadro de dados de calendário?

Por exemplo, quero criar um quadro de dados com colunas: dia, mês, ano.

Esta tabela deve conter todos os dias de 1º de dezembro de 1999 a 1º de dezembro de 2005. Posso fazer isso em outro software como Python ou Excel - mas pode ser feito no SAS?

Tenho esses quadros de dados em R dentro do ambiente global:

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))

Para todos os quadros de dados que começam com "file_", se houver uma coluna com o nome "samplecolumn", quero renomeá-la como "sample_column".

Pensei que poderia fazer isso primeiro identificando todos os quadros de dados começando com "file_" e depois renomeando-os:

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)
    }
}

Essa é a maneira correta de fazer isso em R?

Tenho esses quadros de dados em 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)

Para todos os quadros de dados que começam com "abc_", quero identificar o conjunto de colunas compartilhadas em comum com todos os arquivos e, então, vinculá-los.

Tentei fazer isso da maneira mais longa:

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]
}))

Existe uma maneira mais direta de fazer isso?

Tenho um dataframe em R no ambiente global:

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)

Quero criar uma matriz que me ajude a entender quais nomes de colunas são comuns em todos os quadros de dados e quais não são.

Tentei fazer isso manualmente:

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)

Essa é a maneira correta de fazer isso em R?

A propósito, se estivessem em uma lista, acho que poderíamos fazer assim:

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)

Tenho um quadro de dados em R com uma coluna (formato de data) com entradas como esta:2020-04-01

Posso extrair o número da semana (1 a 52) de cada uma dessas datas usando a week()função em R (usando o calendário jan-dec).

Quero fazer a mesma coisa agora, mas para a semana fiscal, ou seja, o calendário abril-abril.

Tentei algumas opções, mas não parece haver uma maneira rápida de fazer isso. Alguém sabe se há uma maneira padrão de fazer isso em R?

Aqui está um rascunho de ideia em que eu estava trabalhando...

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)

Estou usando R.

Encontrei este site aqui que tem um gráfico sobre dados de desemprego: https://www.bls.gov/charts/employment-situation/civilian-unemployment-rate.htm

Estou tentando baixar os dados para este gráfico (por exemplo, criar um quadro de dados em R).

Tentei fazer Rvestisso primeiro, mas parece que não temos permissão para extrair dados desta página.

Tentei então copiar os dados manualmente e depois usei o cliprpacote r para acessar a área de transferência, mas a formatação está saindo bem errada.

Finalmente, baixei um arquivo SVG correspondente a este gráfico. Espero que em algum lugar no arquivo SVG, os dados subjacentes para este gráfico estejam contidos. Mas ao inspecionar manualmente o código-fonte, não consigo encontrar nada.

Alguém sabe se é possível acessar os dados subjacentes de um arquivo SVG?

Tenho o seguinte gráfico:

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")

Nesta questão anterior ( Dividir aleatoriamente um gráfico em minigráficos ), aprendi como dividir este gráfico em 5 mini subgráficos conectados:

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]
}

Pergunta: Suponha que eu execute esta função 25 vezes e armazene

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()

Em cada um desses subgráficos, quero contar a porcentagem de nós roxos (em relação às cores originais, ou seja, o gráfico que era roxo-alaranjado no início) em cada partição.

Consegui obter um resumo do gráfico original:

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

Mas não tenho certeza de como mesclar esse quadro de dados à lista de subgráficos para obter um resultado como este:

   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

Alguém pode me mostrar como fazer isso?

Eu tenho esta rede de grafos em 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")

Estou tentando escrever uma função que divide aleatoriamente essa rede em 5 subgráficos conectados (ou seja, minigráficos) de modo que cada nó apareça exatamente uma vez.

Acho que, em teoria, isso não deve ser muito difícil de fazer. Eu precisaria identificar aleatoriamente um nó, decidir aleatoriamente quantos vizinhos incluir, selecionar esses vizinhos e removê-los do gráfico... e reiniciar esse processo no gráfico restante. Claro, alguns detalhes adicionais precisariam ser especificados, por exemplo, se o número aleatório especificado exceder o número de nós restantes, então use uma função max, BFS precisaria ser usado para selecionar os nós, etc.

Aqui está minha primeira tentativa de escrever o código:

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")

O resultado acima parece quase correto, mas os nós amarelos (por exemplo, 29) parecem estar violando a conectividade.

Alguma dica sobre como consertar isso?

Escrevi um código opcional para comparar o antes/depois:

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)

Para complementar a resposta incrível de jblood94, aqui está uma função de plotagem rápida que funciona com a resposta de 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()

Nesta questão aqui ( Somando nós em uma rede ), aprendi como encontrar o quadrado dentro da rede original com a maior soma de nós.

Aqui estão os dados para esta pergunta:

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")

E aqui está a função:

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)
    )
  )
)

Esta abordagem está atualmente usando uma abordagem de força bruta em que cada nó é verificado individualmente. Existe alguma maneira em R de reestruturar essa função para que ela seja executada em paralelo ou um tipo diferente de algoritmo de busca que possa varrer a rede com mais eficiência?

Eu tive duas ideias sobre isso:

1. Ideia 1:

   Reescrevendo a função para observar grades quadradas e tesselá-las na rede:

    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. Ideia 2:

   Achei que as comparações poderiam ser feitas de forma vetorizada:

    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)
   

Existe alguma maneira melhor de trabalhar nesse problema?

Suponha que haja uma clínica hospitalar que tenha uma lista de quantos pacientes visitam o hospital todos os dias. Tenho dados de mais de 10 anos – mas os pacientes não visitam a clínica todos os dias. Para dar um exemplo, os dados ficam assim (em 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

Quero tentar responder à seguinte pergunta: Em média - para um determinado mês, qual a percentagem de todos os pacientes desse mês que visitaram a clínica por dia $y$? Por exemplo, suponha que em algum mês eu saiba que 900 pessoas visitaram o hospital - quero saber que até o dia 19, que porcentagem (cumulativamente) dessas 900 provavelmente já visitaram o hospital ATÉ ENTÃO, com base nas tendências anteriores?

Tentei fazer isso identificando manualmente diferentes etapas lógicas:

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())

Mas meu gráfico não está exibindo esta porcentagem cumulativa:

Alguém tem ideias de onde estou bagunçando isso?

EDITAR:

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()

Eu tenho este conjunto de dados:

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

Em cada linha, quero encontrar os primeiros 5 valores não-NA e colocá-los em um novo dataframe.

Pensei em como fazer isso com a seguinte função:

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])
}

O problema agora era como aplicar essa função nas linhas de R. Eu investiguei isso e aparentemente isso é feito com t?

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

Este é o protocolo correto?

Eu tenho um dataframe:

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

Neste dataframe, quero substituir todos os elementos por NA, a menos que atendam a uma destas condições:

• estritamente um número (por exemplo, "54" manter, "54 abc" descartar)
• pertencem a target_string

Eu não tinha certeza de como fazer isso em R usando apply, então tentei escrever um loop:

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)

Existe outra maneira de fazer isso?

Nota: Veja como substituir %in% por %like%:

   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)
}