Charada: Você pode resolver o labirinto que não é tão milho?

cupom com desconto - o melhor site de cupom de desconto cupomcomdesconto.com.br


[Esteartigofoipublicadopelaprimeiravezem[Thisarticlewasfirstpublishedon Posts | Joshua Cook, e gentilmente contribuiu para R-blogueiros]. (Você pode relatar um problema sobre o conteúdo desta página aqui)


Deseja compartilhar seu conteúdo com R-blogueiros? clique aqui se você tiver um blog ou aqui se não tiver.

Riddler Express da FiveThirtyEight

ligação

De Tom Hanrahan, um labirinto que você pode resolver sem se perder em um
campo de milho:

O número em cada caixa indica quantos espaços acima, abaixo, esquerda ou
certo, você deve se mover. (Nenhum movimento diagonal, pessoal.) Começando no
amarelo seis no canto inferior esquerdo, você pode fazer o seu caminho para o
asterisco?

Plano

Eu posso pensar em duas maneiras de resolver esse quebra-cabeça:

  1. Trabalhe de trás para frente a partir do asterisco e encontre todos os caminhos possíveis que
    chegar lá, selecionando o que atinge o destaque 6.
  2. Faça um gráfico a partir dos 6 destacados que conecta cada quadrado (nó)
    para todos os que ele poderia alcançar, use uma pesquisa gráfica para
    encontre o caminho mais curto entre os 6 destacados e o asterisco.

Embora o primeiro seja provavelmente mais eficiente, decidi seguir com o
segundo porque parecia mais fácil de implementar.

Configuração

knitr::opts_chunk$set(echo = TRUE, comment = "#>", cache = TRUE, dpi = 300)
library(mustashe)
library(ggraph)
library(tidygraph)
library(tidyverse)
library(conflicted)
# Handle any namespace conflicts.
conflict_prefer("filter", "dplyr")
conflict_prefer("select", "dplyr")
# Default 'ggplot2' theme.
theme_set(theme_minimal())
# For reproducibility.
set.seed(0)

Eu criei uma matriz a partir da imagem PNG do enigma.

maze_matrix <- matrix(
c(6, 2, 1, 3, 6, 1, 7, 7, 4, 3,
2, 3, 4, 5, 7, 8, 1, 5, 2, 3,
1, 6, 1, 2, 5, 1, 6, 3, 6, 2,
5, 3, 5, 5, 1, 6, 7, 3, 7, 3,
1, 2, 6, 4, 1, 3, 3, 5, 5, 5,
2, 4, 6, 6, 6, 2, 1, 3, 8, 8,
2, 4, 0, 2, 3, 6, 5, 2, 4, 6,
3, 1, 7, 6, 2, 3, 1, 5, 7, 7,
6, 1, 3, 6, 4, 5, 4, 2, 2, 7,
6, 7, 5, 7, 6, 2, 4, 1, 9, 1),
nrow = 10,
byrow = TRUE
)
maze_matrix
#> [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
#> [1,] 6 2 1 3 6 1 7 7 4 3
#> [2,] 2 3 4 5 7 8 1 5 2 3
#> [3,] 1 6 1 2 5 1 6 3 6 2
#> [4,] 5 3 5 5 1 6 7 3 7 3
#> [5,] 1 2 6 4 1 3 3 5 5 5
#> [6,] 2 4 6 6 6 2 1 3 8 8
#> [7,] 2 4 0 2 3 6 5 2 4 6
#> [8,] 3 1 7 6 2 3 1 5 7 7
#> [9,] 6 1 3 6 4 5 4 2 2 7
#> [10,] 6 7 5 7 6 2 4 1 9 1

Crie o gráfico

Existem várias maneiras de fazer essa estrutura gráfica, mas eu decidi ir
com uma abordagem de força bruta - é simples, mas altamente ineficiente.
Resumidamente, fiz um gráfico completo (onde todos os nós estão conectados
para todos os outros nós) e, em seguida, removeu as arestas que não podiam ocorrer com base
nos valores no quadro. Porque a direção da borda é importante
(ou seja, as etapas não são reversíveis), isso resulta em uma
$ (10 vezes 10) ^ 2 - 100 = 10.000 $ número de arestas (subtraindo os 100
bordas que conectariam cada nó a si próprio). Se o labirinto fosse mesmo um
um pouco maior, essa estratégia se tornaria insustentável.

Leia Também  Screenager: tempos de triagem no bioRxiv

Faça as listas de nós e arestas

Para começar, um quadro de dados de todos os nós foi criado a partir de seus $ x $
e $ y $ locais no quadro. Uma coluna value foi feito por
subconjunto da matriz com as coordenadas $ x $ e $ y $.

node_list %
as_tibble() %>%
set_names(c("x", "y")) %>%
mutate(value = map2_dbl(x, y, ~ maze_matrix[.y, .x]),
name = paste(x, y, sep = ",")) %>%
select(name, x, y, value)
node_list
#> # A tibble: 100 x 4
#> name x y value
#>    
#> 1 1,1 1 1 6
#> 2 2,1 2 1 2
#> 3 3,1 3 1 1
#> 4 4,1 4 1 3
#> 5 5,1 5 1 6
#> 6 6,1 6 1 1
#> 7 7,1 7 1 7
#> 8 8,1 8 1 7
#> 9 9,1 9 1 4
#> 10 10,1 10 1 3
#> # … with 90 more rows

Em seguida, foi feita uma lista de arestas de todas as conexões possíveis, removendo o
arestas que conectam um nó a si próprio.

edge_list %
as_tibble() %>%
set_names(c("from", "to")) %>%
filter(from != to)
edge_list
#> # A tibble: 9,900 x 2
#> from to
#>  
#> 1 2,1 1,1
#> 2 3,1 1,1
#> 3 4,1 1,1
#> 4 5,1 1,1
#> 5 6,1 1,1
#> 6 7,1 1,1
#> 7 8,1 1,1
#> 8 9,1 1,1
#> 9 10,1 1,1
#> 10 1,2 1,1
#> # … with 9,890 more rows

A lista de arestas foi removida mantendo apenas as arestas que representavam
possíveis conexões de um nó para outro com base no primeiro nó
valor. Esse processo foi tratado pelo is_possible_connection()

função que utiliza dois nomes de nós e um quadro de dados com o nó
informações e retorna um valor booleano para determinar se uma aresta deve
existir. (Eu usei o stash() função de
"Preciso" para esconder o
resultados, em vez de ter que esperar a execução do código todas as vezes.)

cupom com desconto - o melhor site de cupom de desconto cupomcomdesconto.com.br
stash("edge_list", depends_on = c("edge_list", "node_list"),
{
is_possible_connection <- function(a, b, nodes) {
# Get the requisite information.
a_data % filter(name == !!a) %>% as.list()
b_data % filter(name == !!b) %>% as.list()
val <- a_data$value
# Check all four possible directions.
opt1 <- (a_data$x + val == b_data$x) & (a_data$y == b_data$y)
opt2 <- (a_data$x - val == b_data$x) & (a_data$y == b_data$y)
opt3 <- (a_data$y + val == b_data$y) & (a_data$x == b_data$x)
opt4 <- (a_data$y - val == b_data$y) & (a_data$x == b_data$x)
# Return if any of the four possibilities are true.
return(any(opt1, opt2, opt3, opt4))
}
edge_list %
filter(map2_lgl(from, to, is_possible_connection, nodes = node_list))
})
#> Loading stashed object.
edge_list
#> # A tibble: 233 x 2
#> from to
#>  
#> 1 4,1 1,1
#> 2 8,1 1,1
#> 3 3,1 2,1
#> 4 2,4 2,1
#> 5 3,8 3,1
#> 6 2,1 4,1
#> 7 3,1 4,1
#> 8 4,3 4,1
#> 9 4,5 4,1
#> 10 6,1 5,1
#> # … with 223 more rows

Pesquise no gráfico a solução

Com a lista de arestas e a lista de nós criada, tudo o que resta a fazer foi
Crie um
Objeto "arrumar" e procure o caminho mais curto entre
o local de partida e o destino.

maze_graph %
left_join(node_list, by = "name")
maze_graph
#> # A tbl_graph: 100 nodes and 233 edges
#> #
#> # A directed simple graph with 1 component
#> #
#> # Node Data: 100 x 4 (active)
#> name x y value
#>    
#> 1 4,1 4 1 3
#> 2 8,1 8 1 7
#> 3 3,1 3 1 1
#> 4 2,4 2 4 3
#> 5 3,8 3 8 7
#> 6 2,1 2 1 2
#> # … with 94 more rows
#> #
#> # Edge Data: 233 x 2
#> from to
#>  
#> 1 1 12
#> 2 2 12
#> 3 3 6
#> # … with 230 more rows
start_node <- jhcutils::get_node_index(maze_graph, name == "1,10")
end_node %
convert(to_shortest_path, from = start_node, to = end_node,
.clean = TRUE)
#> # A tbl_graph: 9 nodes and 8 edges
#> #
#> # A rooted tree
#> #
#> # Node Data: 9 x 4 (active)
#> name x y value
#>    
#> 1 4,1 4 1 3
#> 2 4,5 4 5 4
#> 3 1,1 1 1 6
#> 4 7,5 7 5 3
#> 5 1,10 1 10 6
#> 6 1,7 1 7 2
#> # … with 3 more rows
#> #
#> # Edge Data: 8 x 2
#> from to
#>  
#> 1 1 3
#> 2 2 1
#> 3 4 2
#> # … with 5 more rows

Abaixo está um gráfico do gráfico com o caminho da solução destacado em vermelho.
A grade é organizada na mesma orientação que a matriz original de
o enigma e os nós no caminho da solução são rotulados com seus
Coordenadas $ (x, y) $.

plot_maze_graph %
morph(to_shortest_path, from = start_node, to = end_node) %N>%
mutate(is_on_shortest_path = TRUE) %E>%
mutate(is_on_shortest_path = TRUE) %N>%
unmorph() %E>%
mutate(is_on_shortest_path = ifelse(is.na(is_on_shortest_path),
FALSE, TRUE)) %N>%
mutate(is_on_shortest_path = ifelse(is.na(is_on_shortest_path),
FALSE, TRUE),
label = ifelse(is_on_shortest_path, name, NA))
layout_maze_graph <- create_layout(plot_maze_graph, "nicely")
layout_maze_graph$y <- -1 * layout_maze_graph$y
ggraph(layout_maze_graph) +
geom_node_point(aes(color = is_on_shortest_path),
size = 3) +
geom_edge_arc(aes(color = is_on_shortest_path,
alpha = is_on_shortest_path),
width = 0.7, strength = 0.4) +
geom_node_text(aes(label = label), color = "grey25", nudge_x = 0.4, nudge_y = -0.4) +
scale_color_manual(values = c("grey70", "tomato")) +
scale_edge_color_manual(values = c("grey50", "tomato")) +
scale_edge_alpha_manual(values = c(0.1, 0.9)) +
coord_equal() +
theme_graph() +
theme(legend.position = "none")

É possível traçar a solução com o 'ggplot2' normal, embora seja necessário
um pouco mais de trabalho. Todo o código é mostrado abaixo, mas como é um pouco
mais no mato, não expliquei cada passo. Adicionei comentários para ajudar
aqueles que são curiosos.

# A data frame of the node information of the maze graph.
node_idx %
mutate(idx = row_number())
# The names of the nodes on the shortest path (i.e. the solution) were gathered
# and used to get the information of the nodes in the correct order.
maze_soln_paths %
unlist() %>%
enframe() %>%
select(name) %>%
left_join(node_idx, by = "name")
# A long ("tidy") version of the maze matrix was created to use with 'ggplot2'.
long_maze_df %
as.data.frame() %>%
as_tibble() %>%
set_names(1:10) %>%
mutate(row = row_number()) %>%
pivot_longer(-row, names_to = "column", values_to = "value") %>%
mutate(column = as.numeric(column),
label = ifelse(value == 0, "x", as.character(value)))
# The plot was made with the long version of the matrix and the path of
# the solution was added in on top by specifying a different data source.
long_maze_df %>%
ggplot(aes(x = column, y = -1 * row)) +
geom_tile(color = "grey50", fill = NA) +
geom_path(aes(x = x, y = -1 * y),
data = maze_soln_paths, group = "a",
size = 2, alpha = 0.3, color = "tomato") +
geom_point(aes(x = x, y = -1 * y),
data = maze_soln_paths,
size = 6, alpha = 0.3, color = "tomato") +
geom_text(aes(label = label), family = "Arial") +
scale_x_continuous(breaks = 1:10) +
scale_y_continuous(label = function(x) { str_remove(x, "-") },
breaks = -1:-10) +
theme(panel.grid = element_blank(),
axis.title = element_blank()) +
labs()

var vglnk = {key: '949efb41171ac6ec1bf7f206d57e90b8'};

(função (d, t) {
var s = d.createElement
s.src = '//cdn.viglink.com/api/vglnk.js';
var r = d.getElementsByTagName
} (documento, 'script'));

Para Deixe um comentário para o autor, siga o link e comente no blog: Posts | Joshua Cook.

R-bloggers.com oferece atualizações diárias por email sobre notícias e tutoriais do R sobre o aprendizado do R e muitos outros tópicos. Clique aqui se você deseja publicar ou encontrar um emprego em ciência da dados / R.


Deseja compartilhar seu conteúdo com R-blogueiros? clique aqui se você tiver um blog ou aqui se não tiver.



cupom com desconto - o melhor site de cupom de desconto cupomcomdesconto.com.br