Bagaimana cara menghitung "Paths to the White House" menggunakan R?

12

Saya baru saja menemukan analisis hebat ini yang menarik dan indah secara visual:

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

Saya ingin tahu bagaimana "jalur pohon" seperti itu dapat dibangun menggunakan R. Data dan algoritma apa yang diperlukan untuk membuat pohon jalur seperti itu?

Terima kasih.

Tal Galili
sumber
Secara kasar: periksa semua kombinasi dari pemenang di setiap negara bagian dan masukkan hasilnya dalam hipertensi biner 9-redup, susun ulang menjadi sebuah pohon berdasarkan pada perolehan informasi, pangkas cabang-cabang yang berlebihan. 29
mudah Eh @mbq ?! ;-)
Reinstate Monica - G. Simpson
1
Saya pikir mereka benar-benar melakukannya sedikit berbeda: Rangking negara bagian dengan EV, lalu lihat apa yang terjadi jika setiap kandidat menang, turun pohon. Jadi, Anda tidak perlu menghasilkan dan kemudian memangkas. 29
Peter Flom - Reinstate Monica

Jawaban:

10

Wajar menggunakan solusi rekursif.

Data harus terdiri dari daftar negara bagian yang ikut serta, suara pemilihnya, dan keuntungan awal yang diperkirakan untuk kandidat kiri ("biru"). (Nilai mendekati mereproduksi grafik NY Times.) Pada setiap langkah, dua kemungkinan (menang atau kalah) diperiksa; keuntungan diperbarui; jika pada saat itu hasil (menang, kalah, atau seri) dapat ditentukan - berdasarkan suara yang tersisa - maka perhitungan dihentikan; jika tidak, itu diulang secara rekursif untuk status yang tersisa dalam daftar. Jadi: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)

Ini secara efektif memangkas pohon di setiap node, membutuhkan perhitungan jauh lebih sedikit daripada menjelajahi semua hasil yang mungkin. Sisanya hanyalah detail grafis, jadi saya hanya akan membahas bagian-bagian dari algoritma yang penting untuk visualisasi yang efektif.29=512

Gambar

Program lengkapnya berikut. Ini ditulis dengan cara yang cukup fleksibel untuk memungkinkan pengguna menyesuaikan banyak parameter. Bagian penting dari algoritma grafik adalah tata letak pohon. Untuk melakukan ini, plot.pathgunakan widthbidang untuk mengalokasikan ruang horizontal yang tersisa secara proporsional ke dua turunan dari setiap node. Bidang ini awalnya dihitung dengan paths.computejumlah total daun (keturunan) di bawah setiap node. (Jika beberapa perhitungan seperti itu tidak dilakukan, dan pohon biner hanya dibagi dua di setiap node, maka dengan negara kesembilan hanya ada dari total lebar yang tersedia untuk setiap daun, yang jauh terlalu sempit. Siapa pun yang sudah mulai menggambar pohon biner di atas kertas segera mengalami masalah ini!)1/512

Posisi vertikal node disusun dalam deret geometris (dengan rasio umum a) sehingga jarak semakin dekat di bagian pohon yang lebih dalam. Ketebalan cabang dan ukuran simbol daun juga diskalakan dengan kedalaman. (Ini akan menyebabkan masalah dengan simbol lingkaran di daun, karena rasio aspek mereka akan berubah abervariasi. Saya belum repot-repot memperbaikinya.)

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
sumber
2
Itu solusi yang cukup bagus. Dan grafiknya mengesankan. Ada juga partitionspaket yang mungkin menyediakan struktur untuk menyebutkan kemungkinan.
DWin
Wow, Whuber, tidak ada cukup V untuk menandai jawaban Anda!
Tal Galili