jmclawson · July 16, 2021 21:15 · jmclawson · Jul 16, 2021
diff --git a/recreationthursday_2021-07-15.R b/recreationthursday_2021-07-15.R
 library(tidyverse)

 # make a pinwheel: first set up directions. The blades are drawn in different orders for clockwise and counterclockwise
 clockwise_t <- c(2, 1, 3, 4)
 clockwise_f <- c(4, 3, 1, 2)
 direction <- list(clockwise_t, clockwise_f)

 # create a 4-color pinwheel with 4 blades facing the same direction
 get_pinwheel <- 
  function(
    xstart = 0,
    ystart = 0,
    corner = 1,
    center = 1,
    n_colors = 4,
    spin_way = sample(1:2,1),
    color_way = sample(c(-1,1),1)) {
    n_grid <- 2
    color_start <- sample(1:4,1)
    the_colors <- rep(c(1,2,3,4),2)
    
    if (color_way == -1) {
      the_colors <- the_colors %>% 
        .[color_start:(color_start + 3)]
    } else {
      the_colors <- the_colors %>% 
        .[(color_start + 3):color_start]
    }
    the_colors <- the_colors[c(1,2,4,3)]
    
    # set spin direction
    which1 <- direction[[spin_way]]
    
    # create a grid of 1x1 squares; coordinates are per corner: bl=bottom-left, tr=top-right, etc.
    grid_df <- data.frame(
      id = 1:4,
      x_bl = rep(c(xstart, xstart+1), 2),
      y_bl = rep(c(ystart, ystart+1), 
                 each = 2),
      which1 = which1,
      color = the_colors
    ) %>% 
      mutate(
        x_tl = x_bl,
        x_br = x_bl + 1,
        x_tr = x_br,
        y_tl = y_bl + 1,
        y_br = y_bl,
        y_tr = y_tl
      )
    
    # tweak one corner of each square, rotating around the pinwheel so they face the same direction
    grid_df2 <- grid_df %>% 
      mutate(id = 1:4) %>% 
      rowwise() %>% 
      mutate(x = list(c(x_bl, x_tl, 
                        x_tr, x_br)),
             y = list(c(y_bl, y_tl, 
                        y_tr, y_br))) %>% 
      select(id, which1, x, y, color) %>% 
      mutate(x2 = x[which1],
             y2 = y[which1],
             xmean = mean(x),
             ymean = mean(y)) %>% 
      ungroup() %>% 
      # `corner` and `center` pull the tweaked corner in/out
      mutate(
        xchange = ((x2 * corner) + 
                     (xmean * center)) / 
          sum(corner, center),
        ychange = ((y2 * corner) + 
                     (ymean * center)) / 
          sum(corner, center)) %>% 
      rowwise() %>% 
      # There's got to be a better way to do this part
      mutate(x_f = case_when(
        which1 == 1 ~ list(c(xchange, 
                             x[c(2:4)])),
        which1 == 2 ~ list(c(x[1],
                             xchange, 
                             x[c(3,4)])),
        which1 == 3 ~ list(c(x[c(1:2)],
                             xchange, 
                             x[c(4)])),
        which1 == 4 ~ list(c(x[c(1:3)],
                             xchange)),
      ),
      y_f = case_when(
        which1 == 1 ~ list(c(ychange, 
                             y[c(2:4)])),
        which1 == 2 ~ list(c(y[1],
                             ychange, 
                             y[c(3,4)])),
        which1 == 3 ~ list(c(y[c(1:2)],
                             ychange, 
                             y[c(4)])),
        which1 == 4 ~ list(c(y[c(1:3)],
                             ychange)),
      )) %>% 
      select(id, which1, x, y, 
             x_f, y_f, color) 
    
    # unnest it simply
    grid_df3 <- data.frame(
      x = grid_df2$x_f %>% unlist(),
      y = grid_df2$y_f %>% unlist(),
      color = grid_df2$color %>%
        rep(each=4) %>%
        factor(),
      id = grid_df2$id %>% rep(each=4)
    )
    return(grid_df3)
  }

 # Create a n-by-n grid of pinwheels
 get_warpwheels <- function(
  n = 4,
  # `corner` arguments pull the tweaked corner closer to square-shaped. `corner_s` is at the start -- bottom left (0,0) -- `corner_c` is at center, and `corner_f` is at the finish, top right.
  corner_s = 1,
  corner_c = 1,
  corner_f = 1,
  # `center` arguments pull the tweaked corner closer to triangle-shaped. The letters designate start, center, finish, from bottom left to top right.
  center_s = 1,
  center_c = 1,
  center_f = 1,
  # tweak at -1 will reverse the spin pattern
  tweak = 1,
  # the pinwheels follow a pattern in the original, between counterclockwise and clockwise, either -1 or 1.
  pattern = c(1, -1, -1, 1)){
  master_pinwheel <- data.frame(
    x = numeric(),
    y = numeric(),
    color = factor(),
    id = integer())
  dir_pattern <- pattern * tweak
  warp_range <- 1:((n - 1)*2 + 1)
  warp_first <- warp_range[1:n]
  warp_second <- warp_range[(n+1):length(warp_range)]
  corner_warp1 <- seq(
    corner_s, corner_c,
    length.out=length(warp_first))
  corner_warp2 <- seq(
    corner_c, corner_f,
    length.out=length(warp_second))
  corner_warp <- c(corner_warp1,
                    corner_warp2)
  center_warp1 <- seq(
    center_s, center_c,
    length.out=length(warp_first))
  center_warp2 <- seq(
    center_c, center_f,
    length.out=length(warp_second))
  center_warp <- c(center_warp1,
                    center_warp2)
  
  # loop for each column in the grid
  for (x1 in 0:(n - 1)){
    dir_pattern <- 
      dir_pattern * 
      pattern[x1+1] * -1
    direct_pattern <- 
      gsub(-1,2,dir_pattern) %>% 
      as.numeric() %>% 
      rep(5) %>% .[1:n]
    dir_pattern <- pattern * tweak
    
    # loop for each row in a column
    for(y1 in 0:(n-1)){
      corner <- corner_warp[x1+y1+1]
      center <- center_warp[x1+y1+1]
      
      # alternate pinwheels' color_ways
      if ((x1 + y1) %% 2 == 0) {
        color_direction <- -1
      } else {
        color_direction <- 1
      }
      
      # set the spin direction
      this_direct <- direct_pattern[y1+1]
      
      # get one pinwheel
      this_pinwheel <- 
        get_pinwheel(xstart = x1*2,
                     ystart = y1*2,
                     corner = corner,
                     center = center,
                     spin_way = this_direct,
                     color_way = 
                       color_direction) %>% 
        mutate(id = id + y1*n*n + x1*n*n)
      master_pinwheel <- 
        rbind(master_pinwheel,
              this_pinwheel)
    }
  }
  # I forget why this is necessary
  master_pinwheel$id <- rep(1:((n^2)*4), 
                            each = 4)
  return(master_pinwheel)
 }

 # some functions for setting up the data to be amenable to troubleshooting
 prep_to_check <- function(df){
  dimension <- nrow(df)
  df <- df %>% 
    mutate(pinwheel = ceiling(id/4)) %>% 
    rowwise() %>% 
    mutate(point = 
             paste(c(x, y),
                   collapse = ", ")) %>% 
    group_by(id) %>% 
    mutate(row = min(x),
           column = min(y)) %>% 
    ungroup() %>% 
    mutate(position = rep(
      c("bottom_left", "top_left", 
        "top_right", "bottom_right"), 
      dimension/4)) %>% 
    pivot_wider(id_cols = 
                  c("id", "color", 
                    "pinwheel", "row", 
                    "column"), 
                names_from = "position", 
                values_from = "point")
  return(df)
 }

 prep_to_plot <- function(df) {
  df <- df %>% 
    pivot_longer(cols = c("bottom_left",
                          "top_left",
                          "top_right", 
                          "bottom_right"),
                 names_to = "position",
                 values_to = "point") %>% 
    mutate(x = point %>% 
             strsplit(", ") %>% 
             sapply('[', 1) %>% 
             as.numeric(),
           y = point %>% 
             strsplit(", ") %>% 
             sapply('[', 2) %>% 
             as.numeric())
  return(df)
 }

 # rotate the colors of a pinwheel to avoid abutting two blades of the same color
 spin_pinwheel <- function(df, wheel){
  new_order <- df %>% 
    filter(pinwheel == wheel) %>% 
    pull(color) %>% 
    as.numeric() %>% 
    unique() %>% 
    .[c(1,2,4,3)] %>% 
    rep(2) %>% 
    .[2:5] %>% 
    .[c(1,2,4,3)]
  
  this_df <- df
  this_df$color <- as.numeric(this_df$color)
  this_df$color[this_df$pinwheel==wheel] <- 
    new_order
  this_df$color <- factor(this_df$color)
  
  return(this_df)
 }

 # check neighboring colors of each blade; it's undesirable to have a blue beside a blue
 check_neighbors <- function(df){
  df <- df %>% 
    group_by(row) %>% 
    arrange(column) %>% 
    mutate(row_problem = case_when(
      lag(color) == color ~ TRUE,
      TRUE ~ FALSE)) %>% 
    ungroup() %>% 
    group_by(column) %>% 
    arrange(row) %>% 
    mutate(column_problem = case_when(
      lag(color) == color ~ TRUE,
      TRUE ~ FALSE)) %>% 
    ungroup() %>% 
    rowwise() %>% 
    mutate(problem = sum(row_problem, column_problem))
  
  return(df)
 }

 # run all of the prepping, checking, and spinning functions on the entire grid, looping to accommodate anything changed
 check_and_fix <- function(df, times=3,
                          extra = NULL,
                          extratimes = 1){
  df <- prep_to_check(df)
  
  # allow for the spinning of a specific pinwheel
  if (!is.null(extra)) {
    for (w in 1:extratimes){
      df <- spin_pinwheel(df, extra)
    }
  }
  
  for (i in 1:times) {
    to_fix <- df %>% 
      check_neighbors() %>% 
      filter(problem > 0) %>% 
      pull(pinwheel) %>% 
      unique()
    
    for(wheel in to_fix){
      df <- spin_pinwheel(df, wheel)
    }}
  
  to_fix <- df %>% 
    check_neighbors() %>% 
    filter(problem > 0) %>% 
    pull(pinwheel) %>% 
    unique()
  
  if(length(to_fix)>0){
    cat("Errors remain in these pinwheels:\n",
        paste(to_fix))
  }
  
  df <- prep_to_plot(df)
  return(df)
 }

 # plot a grid with the right colors and setup
 plot_pinwheels <- function(pinwheel) {
  pinwheel %>% 
    mutate(
      color = 
        factor(color,
               levels=c(1:4))) %>% 
    ggplot(aes(x = x, y = y, fill = color)) + 
    geom_polygon(aes(group = id),
                 show.legend = FALSE) + 
    coord_fixed() +
    theme_void() + 
    theme(panel.background = element_rect(
      fill = "#919789",
      size = 0)) + 
    scale_fill_manual(values = c(
      "#ffa400", "#004b9c",
      "#f18670", "#008998")) +
    scale_x_continuous(expand=c(0,0)) +
    scale_y_continuous(expand=c(0,0))
 }

 # get something like the original
 get_warpwheels() %>% 
  check_and_fix() %>% 
  plot_pinwheels()

 # get something a little different
 get_warpwheels(
  n = 10, 
  center_s = 3, center_c=1, center_f=0, 
  corner_s = 0, corner_c = 1, corner_f = 3, 
  pattern = c(-1,1,-1,1,-1,
              -1,1,-1,1,-1)) %>% 
  check_and_fix(300) %>% 
  plot_pinwheels()
	library(tidyverse)

	# make a pinwheel: first set up directions. The blades are drawn in different orders for clockwise and counterclockwise
	clockwise_t <- c(2, 1, 3, 4)
	clockwise_f <- c(4, 3, 1, 2)
	direction <- list(clockwise_t, clockwise_f)

	# create a 4-color pinwheel with 4 blades facing the same direction
	get_pinwheel <-
	function(
	xstart = 0,
	ystart = 0,
	corner = 1,
	center = 1,
	n_colors = 4,
	spin_way = sample(1:2,1),
	color_way = sample(c(-1,1),1)) {
	n_grid <- 2
	color_start <- sample(1:4,1)
	the_colors <- rep(c(1,2,3,4),2)

	if (color_way == -1) {
	the_colors <- the_colors %>%
	.[color_start:(color_start + 3)]
	} else {
	the_colors <- the_colors %>%
	.[(color_start + 3):color_start]
	}
	the_colors <- the_colors[c(1,2,4,3)]

	# set spin direction
	which1 <- direction[[spin_way]]

	# create a grid of 1x1 squares; coordinates are per corner: bl=bottom-left, tr=top-right, etc.
	grid_df <- data.frame(
	id = 1:4,
	x_bl = rep(c(xstart, xstart+1), 2),
	y_bl = rep(c(ystart, ystart+1),
	each = 2),
	which1 = which1,
	color = the_colors
	) %>%
	mutate(
	x_tl = x_bl,
	x_br = x_bl + 1,
	x_tr = x_br,
	y_tl = y_bl + 1,
	y_br = y_bl,
	y_tr = y_tl
	)

	# tweak one corner of each square, rotating around the pinwheel so they face the same direction
	grid_df2 <- grid_df %>%
	mutate(id = 1:4) %>%
	rowwise() %>%
	mutate(x = list(c(x_bl, x_tl,
	x_tr, x_br)),
	y = list(c(y_bl, y_tl,
	y_tr, y_br))) %>%
	select(id, which1, x, y, color) %>%
	mutate(x2 = x[which1],
	y2 = y[which1],
	xmean = mean(x),
	ymean = mean(y)) %>%
	ungroup() %>%
	# `corner` and `center` pull the tweaked corner in/out
	mutate(
	xchange = ((x2 * corner) +
	(xmean * center)) /
	sum(corner, center),
	ychange = ((y2 * corner) +
	(ymean * center)) /
	sum(corner, center)) %>%
	rowwise() %>%
	# There's got to be a better way to do this part
	mutate(x_f = case_when(
	which1 == 1 ~ list(c(xchange,
	x[c(2:4)])),
	which1 == 2 ~ list(c(x[1],
	xchange,
	x[c(3,4)])),
	which1 == 3 ~ list(c(x[c(1:2)],
	xchange,
	x[c(4)])),
	which1 == 4 ~ list(c(x[c(1:3)],
	xchange)),
	),
	y_f = case_when(
	which1 == 1 ~ list(c(ychange,
	y[c(2:4)])),
	which1 == 2 ~ list(c(y[1],
	ychange,
	y[c(3,4)])),
	which1 == 3 ~ list(c(y[c(1:2)],
	ychange,
	y[c(4)])),
	which1 == 4 ~ list(c(y[c(1:3)],
	ychange)),
	)) %>%
	select(id, which1, x, y,
	x_f, y_f, color)

	# unnest it simply
	grid_df3 <- data.frame(
	x = grid_df2$x_f %>% unlist(),
	y = grid_df2$y_f %>% unlist(),
	color = grid_df2$color %>%
	rep(each=4) %>%
	factor(),
	id = grid_df2$id %>% rep(each=4)
	)
	return(grid_df3)
	}

	# Create a n-by-n grid of pinwheels
	get_warpwheels <- function(
	n = 4,
	# `corner` arguments pull the tweaked corner closer to square-shaped. `corner_s` is at the start -- bottom left (0,0) -- `corner_c` is at center, and `corner_f` is at the finish, top right.
	corner_s = 1,
	corner_c = 1,
	corner_f = 1,
	# `center` arguments pull the tweaked corner closer to triangle-shaped. The letters designate start, center, finish, from bottom left to top right.
	center_s = 1,
	center_c = 1,
	center_f = 1,
	# tweak at -1 will reverse the spin pattern
	tweak = 1,
	# the pinwheels follow a pattern in the original, between counterclockwise and clockwise, either -1 or 1.
	pattern = c(1, -1, -1, 1)){
	master_pinwheel <- data.frame(
	x = numeric(),
	y = numeric(),
	color = factor(),
	id = integer())
	dir_pattern <- pattern * tweak
	warp_range <- 1:((n - 1)*2 + 1)
	warp_first <- warp_range[1:n]
	warp_second <- warp_range[(n+1):length(warp_range)]
	corner_warp1 <- seq(
	corner_s, corner_c,
	length.out=length(warp_first))
	corner_warp2 <- seq(
	corner_c, corner_f,
	length.out=length(warp_second))
	corner_warp <- c(corner_warp1,
	corner_warp2)
	center_warp1 <- seq(
	center_s, center_c,
	length.out=length(warp_first))
	center_warp2 <- seq(
	center_c, center_f,
	length.out=length(warp_second))
	center_warp <- c(center_warp1,
	center_warp2)

	# loop for each column in the grid
	for (x1 in 0:(n - 1)){
	dir_pattern <-
	dir_pattern *
	pattern[x1+1] * -1
	direct_pattern <-
	gsub(-1,2,dir_pattern) %>%
	as.numeric() %>%
	rep(5) %>% .[1:n]
	dir_pattern <- pattern * tweak

	# loop for each row in a column
	for(y1 in 0:(n-1)){
	corner <- corner_warp[x1+y1+1]
	center <- center_warp[x1+y1+1]

	# alternate pinwheels' color_ways
	if ((x1 + y1) %% 2 == 0) {
	color_direction <- -1
	} else {
	color_direction <- 1
	}

	# set the spin direction
	this_direct <- direct_pattern[y1+1]

	# get one pinwheel
	this_pinwheel <-
	get_pinwheel(xstart = x1*2,
	ystart = y1*2,
	corner = corner,
	center = center,
	spin_way = this_direct,
	color_way =
	color_direction) %>%
	mutate(id = id + y1nn + x1nn)
	master_pinwheel <-
	rbind(master_pinwheel,
	this_pinwheel)
	}
	}
	# I forget why this is necessary
	master_pinwheel$id <- rep(1:((n^2)*4),
	each = 4)
	return(master_pinwheel)
	}

	# some functions for setting up the data to be amenable to troubleshooting
	prep_to_check <- function(df){
	dimension <- nrow(df)
	df <- df %>%
	mutate(pinwheel = ceiling(id/4)) %>%
	rowwise() %>%
	mutate(point =
	paste(c(x, y),
	collapse = ", ")) %>%
	group_by(id) %>%
	mutate(row = min(x),
	column = min(y)) %>%
	ungroup() %>%
	mutate(position = rep(
	c("bottom_left", "top_left",
	"top_right", "bottom_right"),
	dimension/4)) %>%
	pivot_wider(id_cols =
	c("id", "color",
	"pinwheel", "row",
	"column"),
	names_from = "position",
	values_from = "point")
	return(df)
	}

	prep_to_plot <- function(df) {
	df <- df %>%
	pivot_longer(cols = c("bottom_left",
	"top_left",
	"top_right",
	"bottom_right"),
	names_to = "position",
	values_to = "point") %>%
	mutate(x = point %>%
	strsplit(", ") %>%
	sapply('[', 1) %>%
	as.numeric(),
	y = point %>%
	strsplit(", ") %>%
	sapply('[', 2) %>%
	as.numeric())
	return(df)
	}

	# rotate the colors of a pinwheel to avoid abutting two blades of the same color
	spin_pinwheel <- function(df, wheel){
	new_order <- df %>%
	filter(pinwheel == wheel) %>%
	pull(color) %>%
	as.numeric() %>%
	unique() %>%
	.[c(1,2,4,3)] %>%
	rep(2) %>%
	.[2:5] %>%
	.[c(1,2,4,3)]

	this_df <- df
	this_df$color <- as.numeric(this_df$color)
	this_df$color[this_df$pinwheel==wheel] <-
	new_order
	this_df$color <- factor(this_df$color)

	return(this_df)
	}

	# check neighboring colors of each blade; it's undesirable to have a blue beside a blue
	check_neighbors <- function(df){
	df <- df %>%
	group_by(row) %>%
	arrange(column) %>%
	mutate(row_problem = case_when(
	lag(color) == color ~ TRUE,
	TRUE ~ FALSE)) %>%
	ungroup() %>%
	group_by(column) %>%
	arrange(row) %>%
	mutate(column_problem = case_when(
	lag(color) == color ~ TRUE,
	TRUE ~ FALSE)) %>%
	ungroup() %>%
	rowwise() %>%
	mutate(problem = sum(row_problem, column_problem))

	return(df)
	}

	# run all of the prepping, checking, and spinning functions on the entire grid, looping to accommodate anything changed
	check_and_fix <- function(df, times=3,
	extra = NULL,
	extratimes = 1){
	df <- prep_to_check(df)

	# allow for the spinning of a specific pinwheel
	if (!is.null(extra)) {
	for (w in 1:extratimes){
	df <- spin_pinwheel(df, extra)
	}
	}

	for (i in 1:times) {
	to_fix <- df %>%
	check_neighbors() %>%
	filter(problem > 0) %>%
	pull(pinwheel) %>%
	unique()

	for(wheel in to_fix){
	df <- spin_pinwheel(df, wheel)
	}}

	to_fix <- df %>%
	check_neighbors() %>%
	filter(problem > 0) %>%
	pull(pinwheel) %>%
	unique()

	if(length(to_fix)>0){
	cat("Errors remain in these pinwheels:\n",
	paste(to_fix))
	}

	df <- prep_to_plot(df)
	return(df)
	}

	# plot a grid with the right colors and setup
	plot_pinwheels <- function(pinwheel) {
	pinwheel %>%
	mutate(
	color =
	factor(color,
	levels=c(1:4))) %>%
	ggplot(aes(x = x, y = y, fill = color)) +
	geom_polygon(aes(group = id),
	show.legend = FALSE) +
	coord_fixed() +
	theme_void() +
	theme(panel.background = element_rect(
	fill = "#919789",
	size = 0)) +
	scale_fill_manual(values = c(
	"#ffa400", "#004b9c",
	"#f18670", "#008998")) +
	scale_x_continuous(expand=c(0,0)) +
	scale_y_continuous(expand=c(0,0))
	}

	# get something like the original
	get_warpwheels() %>%
	check_and_fix() %>%
	plot_pinwheels()

	# get something a little different
	get_warpwheels(
	n = 10,
	center_s = 3, center_c=1, center_f=0,
	corner_s = 0, corner_c = 1, corner_f = 3,
	pattern = c(-1,1,-1,1,-1,
	-1,1,-1,1,-1)) %>%
	check_and_fix(300) %>%
	plot_pinwheels()