Apakah mungkin untuk membuat plot "set paralel" menggunakan R?

16

Berkat pertanyaan Tormod (diposting di sini ), saya menemukan plot Set Paralel . Berikut ini adalah contoh untuk tampilannya: masukkan deskripsi gambar di sini (Ini adalah visualisasi dari dataset Titanic. Misalnya, menunjukkan bagaimana sebagian besar wanita yang tidak bertahan hidup milik kelas tiga ...)

Saya ingin sekali dapat mereproduksi plot seperti itu dengan R. Apakah itu mungkin dilakukan?

Terima kasih, Tal

Tal Galili
sumber
1
Untuk ide-ide tentang grafik, saya selalu memeriksa galeri grafik R. Inilah sesuatu dari sana yang agak seperti apa yang Anda minta: R Graph Gallery parallel . Saya menemukannya dengan mengklik paralel di tag cloud, tetapi mungkin ada opsi yang lebih baik.
Nick Sabbe
1
Terima kasih Nick. Tapi ini tidak akan berfungsi untuk data kategorikal tanpa mengubah kode (mungkin juga bukan fungsi terbaik untuk membangunnya). Saya harap seseorang mungkin telah melakukan sesuatu yang serupa ...
Tal Galili

Jawaban:

25

Ini adalah versi yang hanya menggunakan grafis dasar, terima kasih atas komentar Hadley. (Untuk versi sebelumnya, lihat edit riwayat).

percobaan ketiga

parallelset <- function(..., freq, col="gray", border=0, layer, 
                             alpha=0.5, gap.width=0.05) {
  p <- data.frame(..., freq, col, border, alpha, stringsAsFactors=FALSE)
  n <- nrow(p)
  if(missing(layer)) { layer <- 1:n }
  p$layer <- layer
  np <- ncol(p) - 5
  d <- p[ , 1:np, drop=FALSE]
  p <- p[ , -c(1:np), drop=FALSE]
  p$freq <- with(p, freq/sum(freq))
  col <- col2rgb(p$col, alpha=TRUE)
  if(!identical(alpha, FALSE)) { col["alpha", ] <- p$alpha*256 }
  p$col <- apply(col, 2, function(x) do.call(rgb, c(as.list(x), maxColorValue = 256)))
  getp <- function(i, d, f, w=gap.width) {
    a <- c(i, (1:ncol(d))[-i])
    o <- do.call(order, d[a])
    x <- c(0, cumsum(f[o])) * (1-w)
    x <- cbind(x[-length(x)], x[-1])
    gap <- cumsum( c(0L, diff(as.numeric(d[o,i])) != 0) )
    gap <- gap / max(gap) * w
    (x + gap)[order(o),]
  }
  dd <- lapply(seq_along(d), getp, d=d, f=p$freq)
  par(mar = c(0, 0, 2, 0) + 0.1, xpd=TRUE )
  plot(NULL, type="n",xlim=c(0, 1), ylim=c(np, 1),
       xaxt="n", yaxt="n", xaxs="i", yaxs="i", xlab='', ylab='', frame=FALSE)
  for(i in rev(order(p$layer)) ) {
     for(j in 1:(np-1) )
     polygon(c(dd[[j]][i,], rev(dd[[j+1]][i,])), c(j, j, j+1, j+1),
             col=p$col[i], border=p$border[i])
   }
   text(0, seq_along(dd), labels=names(d), adj=c(0,-2), font=2)
   for(j in seq_along(dd)) {
     ax <- lapply(split(dd[[j]], d[,j]), range)
     for(k in seq_along(ax)) {
       lines(ax[[k]], c(j, j))
       text(ax[[k]][1], j, labels=names(ax)[k], adj=c(0, -0.25))
     }
   }           
}

data(Titanic)
myt <- subset(as.data.frame(Titanic), Age=="Adult", 
              select=c("Survived","Sex","Class","Freq"))
myt <- within(myt, {
  Survived <- factor(Survived, levels=c("Yes","No"))
  levels(Class) <- c(paste(c("First", "Second", "Third"), "Class"), "Crew")
  color <- ifelse(Survived=="Yes","#008888","#330066")
})

with(myt, parallelset(Survived, Sex, Class, freq=Freq, col=color, alpha=0.2))
Aaron - Pasang kembali Monica
sumber
Aaron, wow, jawaban fantastis - Saya berharap saya bisa menandainya V dua kali. Terima kasih!
Tal Galili
2
Senang kamu menyukainya. Itu menyenangkan. :) Satu-satunya bagian yang sulit adalah mendapatkan tempat di mana bar harus dimulai dan diakhiri (yang ada di getpsubfungsi); sisanya hanya menggambar poligon.
Aaron - Pasang kembali Monica
1
Hanya panel.textgaris lain . Lihat edit.
Aaron - Pasang kembali Monica
1
Anda dapat melakukan transparansi dalam grafik dasar juga.
Hadley
2
Kamu benar. Saya benar-benar lupa tentang itu, begitu terbiasa dengan cara kisi melakukan sesuatu. Untuk orang lain yang tertarik, Anda menambahkan beberapa karakter ke string warna Anda, misalnya #FF000080,. ?rgbmemiliki detail.
Aaron - Pasang kembali Monica