представление мозаичного сюжета в виде дерева - PullRequest
Новая
       34

представление мозаичного сюжета в виде дерева

3 голосов
/ 14 февраля 2011

Я хочу визуализировать мозаичный сюжет в виде дерева. Например 

mosaicplot(~ Sex + Age + Survived, data = Titanic, color = TRUE)

Теперь я хочу представить это в виде дерева, где первый узел например, быть полом, второй узел - возрастом, а в терминальном узле - количество выживших людей. Может быть, это что-то вроде http://addictedtor.free.fr/graphiques/RGraphGallery.php?graph=84, где вместо p указано количество импульсов. Есть ли функция в R, чтобы сделать это, или я должен написать это самостоятельно, взглянув при функции party:::plot.BinaryTree

Ответы [ 2 ]

3 голосов
/ 20 февраля 2011

Вот как мне удалось получить то, что я хотел, с прекрасной упаковкой igraph. Код - безобразный взлом. Будет здорово, если у вас есть предложения 

library(igraph)
rm(list=ls())
req.data <- as.data.frame(Titanic)
lookup <- c("M","F","C","A","N","Y")
names(lookup) <- c("Male","Female","Child","Adult","Yes","No")

req.data$board <- "board"
req.data$Class.m <- paste(req.data$board,req.data$Class,sep="_")
req.data$Sex.m <- paste(req.data$board,req.data$Class,req.data$Sex,
                        sep="_")
req.data$Age.m <- paste(req.data$board,req.data$Class,req.data$Sex,
                        req.data$Age,sep="_")
req.data$Survived.m <- paste(req.data$board,req.data$Class,req.data$Sex,
                           req.data$Age,req.data$Survived,sep="_")

tmp <- data.frame(from=
                  do.call("c",lapply(req.data[,c("board",
                                                 "Class.m",
                                                 "Sex.m",
                                                 "Age.m")],as.character)),
                  to=do.call("c",lapply(req.data[,c("Class.m",
                    "Sex.m",
                    "Age.m",
                    "Survived.m")],as.character)),
                  stringsAsFactors=FALSE)

tmp  <- tmp [!duplicated(tmp ),];rownames(tmp) <- NULL
tmp$num <- unlist(lapply(strsplit(tmp$to,"_"),
                         FUN=function(x){
                           check1 <- req.data$Class==x[2]
                           check2 <- req.data$Sex == x[3]
                           check3 <- req.data$Age == x[4]
                           check4 <- req.data$Survived == x[5]
                           sum(req.data$Freq[ifelse(is.na(check1),TRUE,check1)   &
                                             ifelse(is.na(check2),TRUE,check2)   &
                                             ifelse(is.na(check3),TRUE,check3)   &
                                             ifelse(is.na(check4),TRUE,check4)])}))


g <- graph.data.frame(tmp, directed=TRUE)
V(g)$label <- unlist(lapply(strsplit(V(g)$name,"_"),
                            FUN=function(y){ifelse(y[length(y)] %in% names(lookup),
                              lookup[y[length(y)]],y[length(y)])}))
E(g)$label <- tmp$num
plot(g,layout=layout.reingold.tilford,ylim=c(1,-1),edge.arrow.size=0.5,vertex.size=7)
legend("topleft", paste(lookup ,names(lookup),sep=" : "),ncol=2,bty="n",cex=0.7) 
### To find the case for crew members 
tmp1  <- tmp [grepl("Crew",tmp$from),];rownames(tmp1) <- NULL
g <- graph.data.frame(tmp1, directed=TRUE)
V(g)$label <- unlist(lapply(strsplit(V(g)$name,"_"),
                            FUN=function(y){ifelse(y[length(y)] %in% names(lookup),
                              lookup[y[length(y)]],y[length(y)])}))
E(g)$label <- tmp1$num
plot(g,layout=layout.reingold.tilford,ylim=c(1,-1),edge.arrow.size=0.5)
legend("topleft", paste(lookup ,names(lookup),sep=" : "),ncol=2,bty="n",cex=0.7)

Вот сюжет, который я генерирую. Вы можете изменить цвета вершин / ребер / размер по своему усмотрению required plot

0 голосов
/ 28 января 2014

Это довольно близко и выглядит намного проще для меня .. Я публикую это здесь на случай, если это может быть полезно.Сначала я преобразовываю ftable в более традиционный длинный фрейм данных, используя expand.dft https://stat.ethz.ch/pipermail/r-help/2009-January/185561.html Затем я просто использую функцию plot.dendrite из пакета plotrix. 

 expand.dft <- function(x, var.names = NULL, freq = "Freq", ...)
{
  #  allow: a table object, or a data frame in frequency form
  if(inherits(x, "table"))
    x <- as.data.frame.table(x, responseName = freq)

  freq.col <- which(colnames(x) == freq)
  if (length(freq.col) == 0)
      stop(paste(sQuote("freq"), "not found in column names"))

  DF <- sapply(1:nrow(x),
               function(i) x[rep(i, each = x[i, freq.col]), ],
               simplify = FALSE)

  DF <- do.call("rbind", DF)[, -freq.col]

  for (i in 1:ncol(DF))
  {
    DF[[i]] <- type.convert(as.character(DF[[i]]), ...)

  }

  rownames(DF) <- NULL

  if (!is.null(var.names))
  {
    if (length(var.names) < dim(DF)[2])
    {
      stop(paste("Too few", sQuote("var.names"), "given."))
    } else if (length(var.names) > dim(DF)[2]) {
      stop(paste("Too many", sQuote("var.names"), "given."))
    } else {
      names(DF) <- var.names
    }
  }

  DF
}

library(plotrix)
r = ftable(Titanic)
plot.dendrite(makeDendrite(expand.dft(data.frame(r))))

enter image description here

...