¿Cómo calcular "Caminos a la Casa Blanca" usando R?

12

Acabo de encontrar este gran análisis que es interesante y hermoso visualmente:

http://www.nytimes.com/interactive/2012/11/02/us/politics/paths-to-the-white-house.html

Tengo curiosidad por saber cómo se puede construir un "árbol de ruta" con R. ¿Qué datos y algoritmos se necesitan para construir un árbol de ruta?

Gracias.

Tal Galili
fuente
Aproximadamente: verifique todas las combinaciones del ganador en cada estado y coloque los resultados en un hipertable binario de 9 dim, vuelva a ordenar en un árbol en función de la ganancia de información, pode las ramas redundantes. 29
fácil Eh @mbq ?! ;-)
Reinstale a Monica - G. Simpson el
1
Creo que en realidad lo hicieron de manera ligeramente diferente: clasifique los estados por EV, luego vea qué sucede si cada candidato gana, bajando del árbol. Por lo tanto, no necesita generar y luego podar. 29
Peter Flom - Restablece a Monica

Respuestas:

10

Es natural usar una solución recursiva.

Los datos deben consistir en una lista de los estados en juego, sus votos electorales y la presunta ventaja inicial para el candidato de la izquierda ("azul"). (Un valor de se acerca a la reproducción del gráfico del NY Times). En cada paso, se examinan las dos posibilidades (la izquierda gana o pierde); la ventaja se actualiza; si en ese momento se puede determinar el resultado (victoria, derrota o empate), en base a los votos restantes, entonces el cálculo se detiene; de lo contrario, se repite recursivamente para los estados restantes en la lista. Así:47

paths.compute <- function(start, options, states) {
  if (start > sum(options)) x <- list(Id="O", width=1)
  else if (start < -sum(options)) x <- list(Id="R", width=1)
  else if (length(options) == 0 && start == 0) x <- list(Id="*", width=1)
  else {
    l <- paths.compute(start+options[1], options[-1], states[-1])
    r <- paths.compute(start-options[1], options[-1], states[-1])
    x <- list(Id=states[1], L=l, R=r, width=l$width+r$width, node=TRUE)
  }
  class(x) <- "path"
  return(x)
}

states <- c("FL", "OH", "NC", "VA", "WI", "CO", "IA", "NV", "NH")
votes <- c(29, 18, 15, 13, 10, 9, 5, 6, 4)
p <- paths.compute(47, votes, states)

Esto poda efectivamente el árbol en cada nodo, lo que requiere mucho menos cómputo que explorar todos los resultados posibles. El resto es solo un detalle gráfico, por lo que analizaré solo aquellas partes del algoritmo que son esenciales para una visualización efectiva.29=512

Imagen

El programa completo sigue. Está escrito de manera moderadamente flexible para permitir al usuario ajustar muchos de los parámetros. La parte crucial del algoritmo gráfico es el diseño del árbol. Para hacer esto, plot.pathutiliza un widthcampo para asignar proporcionalmente el espacio horizontal restante a los dos descendientes de cada nodo. Este campo se calcula inicialmente paths.computecomo el número total de hojas (descendientes) debajo de cada nodo. (Si no se realiza algún cálculo de este tipo, y el árbol binario simplemente se divide por la mitad en cada nodo, entonces, en el noveno estado, solo hay del ancho total disponible para cada hoja, que es demasiado angosto. Cualquiera que ha comenzado a dibujar un árbol binario en papel, ¡pronto experimentó este problema!)1/512

Las posiciones verticales de los nodos están dispuestas en una serie geométrica (con una relación común a) para que el espacio se acerque en las partes más profundas del árbol. Los grosores de las ramas y los tamaños de los símbolos de las hojas también se escalan por profundidad. (Esto causará problemas con los símbolos circulares en las hojas, porque sus relaciones de aspecto cambiarán según las avariaciones. No me he molestado en arreglar eso).

paths.compute <- function(start, options, states) {
  if (start > sum(options)) x <- list(Id="O", width=1)
  else if (start < -sum(options)) x <- list(Id="R", width=1)
  else if (length(options) == 0 && start == 0) x <- list(Id="*", width=1)
  else {
    l <- paths.compute(start+options[1], options[-1], states[-1])
    r <- paths.compute(start-options[1], options[-1], states[-1])
    x <- list(Id=states[1], L=l, R=r, width=l$width+r$width, node=TRUE)
  }
  class(x) <- "path"
  return(x)
}

plot.path <- function(p, depth=0, x0=1/2, y0=1, u=0, v=1, a=.9, delta=0,
               x.offset=0.01, thickness=12, size.leaf=4, decay=0.15, ...) {
  #
  # Graphical symbols
  #
  cyan <- rgb(.25, .5, .8, .5); cyan.full <- rgb(.625, .75, .9, 1)
  magenta <- rgb(1, .7, .775, .5); magenta.full <- rgb(1, .7, .775, 1)
  gray <- rgb(.95, .9, .4, 1)
  #
  # Graphical elements: circles and connectors.
  #
  circle <- function(center, radius, n.points=60) {
    z <- (1:n.points) * 2 * pi / n.points
    t(rbind(cos(z), sin(z)) * radius + center)
  }
  connect <- function(x1, x2, veer=0.45, n=15, ...){
    x <- seq(x1[1], x1[2], length.out=5)
    y <- seq(x2[1], x2[2], length.out=5)
    y[2] = veer * y[3] + (1-veer) * y[2]
    y[4] = veer * y[3] + (1-veer) * y[4]
    s = spline(x, y, n)
    lines(s$x, s$y, ...)
  }
  #
  # Plot recursively:
  #
  scale <- exp(-decay * depth)
  if (is.null(p$node)) {
    if (p$Id=="O") {dx <- -y0; color <- cyan.full} 
    else if (p$Id=="R") {dx <- y0; color <- magenta.full}
    else {dx = 0; color <- gray}
    polygon(circle(c(x0 + dx*x.offset, y0), size.leaf*scale/100), col=color, border=NA)
    text(x0 + dx*x.offset, y0, p$Id, cex=size.leaf*scale)
  } else {  
    mid <- ((delta+p$L$width) * v + (delta+p$R$width) * u) / (p$L$width + p$R$width + 2*delta)
    connect(c(x0, (x0+u)/2), c(y0, y0 * a), lwd=thickness*scale, col=cyan, ...)
    connect(c(x0, (x0+v)/2), c(y0, y0 * a), lwd=thickness*scale, col=magenta,  ...)
    plot(p$L, depth=depth+1, x0=(x0+u)/2, y0=y0*a, u, mid, a, delta, x.offset, thickness, size.leaf, decay, ...)
    plot(p$R, depth=depth+1, x0=(x0+v)/2, y0=y0*a, mid, v, a, delta, x.offset, thickness, size.leaf, decay, ...)
  }
}

plot.grid <- function(p, y0=1, a=.9, col.text="Gray", col.line="White", ...) {
  #
  # Plot horizontal lines and identifiers.
  #
  if (!is.null(p$node)) {
    abline(h=y0, col=col.line, ...)
    text(0.025, y0*1.0125, p$Id, cex=y0, col=col.text, ...)
    plot.grid(p$L, y0=y0*a, a, col.text, col.line, ...)
    plot.grid(p$R, y0=y0*a, a, col.text, col.line, ...)
  }
}

states <- c("FL", "OH", "NC", "VA", "WI", "CO", "IA", "NV", "NH")
votes <- c(29, 18, 15, 13, 10, 9, 5, 6, 4)
p <- paths.compute(47, votes, states)

a <- 0.925
eps <- 1/26
y0 <- a^10; y1 <- 1.05

mai <- par("mai")
par(bg="White", mai=c(eps, eps, eps, eps))
plot(c(0,1), c(a^10, 1.05), type="n", xaxt="n", yaxt="n", xlab="", ylab="")
rect(-eps, y0 - eps * (y1 - y0), 1+eps, y1 + eps * (y1-y0), col="#f0f0f0", border=NA)
plot.grid(p, y0=1, a=a, col="White", col.text="#888888")
plot(p, a=a, delta=40, thickness=12, size.leaf=4, decay=0.2)
par(mai=mai)
whuber
fuente
2
Esa es una buena solución. Y los gráficos son impresionantes. También hay un partitionspaquete que podría haber proporcionado una estructura para enumerar las posibilidades.
DWin
¡Guau, Whuber, no hay suficientes V para marcar tu respuesta!
Tal Galili