R을 사용하여“백악관으로가는 길”을 계산하는 방법?


12

나는 방금 흥미롭고 아름다운이 위대한 분석을 보았습니다.

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

R을 사용하여 이러한 "경로 트리"를 어떻게 구성 할 수 있는지 궁금합니다. 이러한 경로 트리를 구성하려면 어떤 데이터와 알고리즘이 필요합니까?

감사.


대략 : 각 주에서 우승자 의 조합을 모두 확인 하고 결과를 9 차원 이진 하이퍼 테이블에 놓고 정보 게인을 기반으로 트리로 재정렬하고 중복 분기를 제거합니다. 29

쉬운 Eh @mbq ?! ;-)
Monica Monica 복원-G. Simpson

1
나는 그들이 실제로 다르게 다르게 생각합니다. EV로 상태를 순위를 매기고 각 후보자가 이기면 어떻게 될지, 나무 아래로 내려갑니다. 따라서 을 생성 한 다음 정리할 필요가 없습니다 . 29
Peter Flom-Monica Monica 복원

답변:


10

재귀 솔루션을 사용하는 것이 당연합니다.

데이터는 사용중인 주 목록, 선거인 투표 및 왼쪽 ( "파란색") 후보에 대한 추정 된 시작 이점으로 구성되어야합니다. ( 의 값은 NY Times 그래픽을 재현하는 데 가깝습니다.) 각 단계에서 두 가지 가능성 (왼쪽 승패)이 검사됩니다. 이점이 업데이트됩니다. 이 시점에서 결과 (승리, 패배 또는 동점)를 나머지 투표 수에 따라 결정할 수 있다면 계산이 중단됩니다. 그렇지 않으면 목록의 나머지 상태에 대해 반복적으로 반복됩니다. 그러므로: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)

이것은 각 노드에서 트리를 효과적으로 제거하여 가능한 모든 결과를 탐색하는 것보다 훨씬 적은 계산을 요구 합니다. 나머지는 단지 그래픽적인 세부 사항이므로 효과적인 시각화에 필수적인 알고리즘 부분 만 설명하겠습니다.29=512

영상

전체 프로그램은 다음과 같습니다. 사용자가 많은 매개 변수를 조정할 수 있도록 적당히 유연한 방식으로 작성되었습니다. 그래프 알고리즘의 중요한 부분은 트리 레이아웃입니다. 이렇게하려면 필드를 plot.path사용 width하여 나머지 수평 공간을 각 노드의 두 자손에 비례 적으로 할당하십시오. 이 필드는 처음에 paths.compute각 노드 아래의 총 잎 수 (자손)로 계산됩니다 . (이러한 계산이 이루어지지 않고 이진 트리가 각 노드에서 단순히 절반으로 나뉘면 아홉 번째 상태에서는 각 리프에 사용할 수있는 총 너비의 만 너무 좁습니다. 종이에 이진 트리를 그리기 시작했으며 곧이 문제가 발생했습니다!)1/512

노드의 수직 위치 a는 트리의 깊은 부분에서 간격이 가까워 지도록 일련의 기하학적 시리즈 (공통 비율 ) 로 배열됩니다 . 가지의 두께와 잎 기호의 크기도 깊이에 따라 조정됩니다. (이것은 잎의 ​​종횡비가 변화함에 a따라 변하기 때문에 잎에서 원형 기호에 문제를 일으킬 것입니다 . 나는 그것을 고치려고하지 않았습니다.)

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)

2
꽤 좋은 해결책입니다. 그리고 그래픽이 인상적입니다. partitions가능성을 열거하기위한 구조를 제공 한 패키지도 있습니다.
DWin

와우, Whuber, 당신의 답을 표시하기에 V가 충분하지 않습니다!
탈 Galili
당사 사이트를 사용함과 동시에 당사의 쿠키 정책개인정보 보호정책을 읽고 이해하였음을 인정하는 것으로 간주합니다.
Licensed under cc by-sa 3.0 with attribution required.