This image (.gif) was created using Markov Chain Monte Carlo (MCMC), the chain targets a density defined on a square of the x-y plane. The density has high probability mass on the message, therefore the text becomes visible as the chain visits more often these regions.
The code in R is relatively simple and was adapted from an initial suggestion from Claude.
# Required library
library(png)
library(scales)
library(magick)
# Function to create a 2D posterior grid for a text message
create_posterior <- function(message, grid_size = 100) {
# Temporary file to save the image
temp_file <- tempfile(fileext = ".png")
# Create the text image with lower resolution
png(temp_file, width = grid_size, height = grid_size, bg = "white")
# Reset graphical parameters
par(mar = c(0, 0, 0, 0), xaxs = "i", yaxs = "i", family = "sans")
plot.new()
plot.window(xlim = c(0, 1), ylim = c(0, 1))
# Render text with multi-line support
text(0.5, 0.5,
labels = message,
cex = 4, # Font size
font = 2, # Bold
adj = 0.5, # Center alignment
xpd = NA) # Allow drawing outside plot region
dev.off()
# Read the image back into R
img <- readPNG(temp_file)
# Remove the temporary file
unlink(temp_file)
# Convert to grayscale and create probability grid
grid_values <- apply(img[,,1:3], c(1,2), mean) < 0.5
grid_values <-ifelse(grid_values==0,0.05,1)
posterior <- matrix(as.numeric(grid_values), nrow = grid_size, ncol = grid_size)
# Flip the posterior vertically
posterior <- posterior[nrow(posterior):1, ]
return(posterior)
}
# Metropolis-Hastings MCMC sampler
metropolis_hastings_posterior <- function(posterior, n_iterations = 1e+4, thinning = 100,
start = c(1,1)) {
grid_dims <- dim(posterior)
grid_height <- grid_dims[1]
grid_width <- grid_dims[2]
# Initialize first point
current_x <- start[1]
current_y <- start[2]
# Storage for samples
samples <- matrix(0, nrow = n_iterations %/% thinning + 1, ncol = 2)
samples[1, ] <- c(current_x, current_y)
# Current probability
current_prob <- posterior[current_y, current_x]
for (i in 1:n_iterations) {
if(i %% thinning ==0){
# Propose new point (random walk)
proposed_x <- current_x + sample(-5:5, 1)
proposed_y <- current_y + sample(-5:5, 1)
# Boundary check
proposed_x <- max(1, min(proposed_x, grid_width))
proposed_y <- max(1, min(proposed_y, grid_height))
# Proposed probability
proposed_prob <- posterior[proposed_y, proposed_x]
# Acceptance probability
if(current_prob==0)
acceptance_prob=1
else
acceptance_prob <- min(1, proposed_prob / current_prob)
# Accept or reject
if (runif(1) < acceptance_prob) {
current_x <- proposed_x
current_y <- proposed_y
current_prob <- proposed_prob
}
# Store new current point
samples[i %/% thinning + 1, ] <- c(current_x, current_y)
}
}
return(list(samples = samples))
}
# Main execution
# Read file
file_path <- "Xmas.txt"
message <- readLines(file_path)
# Convert to uppercase and combine lines
message <- toupper(paste(message, collapse = "\n"))
# Create the posterior with lower resolution
grid_size <- 250 # Reduced grid size
posterior <- create_posterior(message, grid_size)
set.seed(12345)
# Run Metropolis-Hastings MCMC
mcmc_result_red <- metropolis_hastings_posterior(posterior, n_iterations = 1e+5,
thinning =1, start=c(1,1))
mcmc_result_green <- metropolis_hastings_posterior(posterior, n_iterations = 1e+5,
thinning =1, start=c(250,250))
# Path plot
plot(mcmc_result_green$samples[, 1], mcmc_result_green$samples[, 2],
type = "l", col = alpha("darkgreen",0.15),
xlab = "x", ylab = "y",
xlim = c(1, dim(posterior)[2]),
ylim = c(1, dim(posterior)[1]),
asp = 1)
lines(mcmc_result_red$samples[, 1], mcmc_result_red$samples[, 2],
type = "l", col = alpha("red",0.15),
xlab = "x", ylab = "y",
xlim = c(1, dim(posterior)[2]),
ylim = c(1, dim(posterior)[1]),
asp = 1)
# Function to create animated GIF of MCMC path
create_mcmc_gif <- function(posterior, mcmc_result_red, mcmc_result_green,
output_file = "mcmc_path.gif", skip = 500, max_frames = 300) {
# Prepare temporary directory for frames
temp_dir <- tempdir()
# Create frames
frames <- seq(1, nrow(mcmc_result_red$samples), by = skip)
frames <- frames[1:min(length(frames), max_frames)]
image_files <- c()
for (i in frames) {
# Temporary PNG file for this frame
temp_png <- file.path(temp_dir, paste0("frame_", i, ".png"))
# Create plot for this frame
png(temp_png, width = 800, height = 800)
par(mar = c(4, 4, 2, 1))
# Plot the posterior grid
image(1:nrow(posterior), 1:ncol(posterior), posterior,
col = "white",
xlab = "x", ylab = "y")
# Plot the path up to this point
points(mcmc_result_green$samples[1:i, 1], mcmc_result_green$samples[1:i, 2],
type = "l", col = alpha("darkgreen",0.15),, lwd = 2)
points(mcmc_result_green$samples[i, 1], mcmc_result_green$samples[i, 2],
col = "blue", pch = 16, cex = 1.5)
points(mcmc_result_red$samples[1:i, 1], mcmc_result_red$samples[1:i, 2],
type = "l", col = alpha("red",0.15),, lwd = 2)
points(mcmc_result_red$samples[i, 1], mcmc_result_red$samples[i, 2],
col = "blue", pch = 16, cex = 1.5)
dev.off()
image_files <- c(image_files, temp_png)
}
# Create GIF
image_list <- image_read(image_files)
image_write(image_animate(image_list, fps = 10),
path = output_file)
# Clean up temporary files
unlink(image_files)
return(output_file)
}
gif_path <- create_mcmc_gif(posterior, mcmc_result_red, mcmc_result_green, "mcmc_path.gif")
cat("GIF created at:", gif_path, "\n")