Симметричная, скрипичная сюжетная гистограмма?

Question

Как создать гистограмму, в которой центр каждого стержня лежит вдоль общей оси? Это будет выглядеть как скрипичный сюжет с ступенчатыми краями.

Я хотел бы сделать это в решетке и не против настраивать функции панели и т. Д., Но был бы рад использовать базовую графику R или даже ggplot2. (Я еще не попал в ggplot2, но в какой-то момент окунуться.)

(Почему я хочу это сделать? Я думаю, что это может быть полезной заменой для скрипичного графика, когда данные дискретны и происходит с несколькими [5-50] равномерно разнесенными числовыми значениями. Каждый бит затем представляет точку. Конечно, я мог бы просто создать нормальную гистограмму. Но я думаю, что иногда полезно отображать как коробку-и-бакенбард сюжет и скрипичный сюжет. С дискретными данными через регулярные интервалы симметричная гистограмма с той же ориентацией, что и ящик, позволяет сравнивать подробную структуру данных с коробкой, так же, как и график скрипки. В этом случае симметричная гистограмма могла бы быть более информативным, чем скрипичный сюжет. (Боб-план может быть другой альтернативой тому, что я только что описал, хотя на самом деле мои данные не являются буквально дискретными - он просто сходится почти рядом регулярных значений. Это делает пакет beanplot для R менее полезным для меня, если я не нормализую значения, сопоставляя их с ближайшим регулярным значением.))

Ниже приведено 30 подмножество наблюдений некоторых данных, которое генерируется агент- на основе моделирования:

df30 <- data.frame(crime.v=c(0.2069526, 0.2063516, 0.06919754, 
0.2080366, -0.06975912, 0.206277, 0.3457634, 0.2058985, 0.3428499, 
0.3428159, 0.06746109, -0.07068694, 0.4826098, -0.06910966, 0.06769761, 
0.2098732, 0.3482267, 0.3483602, 0.4829777, 0.06844112, 0.2093492, 
0.4845478, 0.2093505, 0.3482845, 0.3459249, 0.2106339, 0.2098397, 
0.4844956, 0.2108985, 0.2107984), bias=c("beast", "beast", "beast", 
"beast", "beast", "beast", "beast", "beast", "beast", "beast", "beast", 
"beast", "beast", "beast", "beast", "virus", "virus", "virus", "virus", 
"virus", "virus", "virus", "virus", "virus", "virus", "virus", "virus", 
"virus", "virus", "virus")) 

dataframe имени df с полным набором из 600 наблюдений в качестве RDATA файл можно скачать по этой ссылке: CVexample.rdata.

В crime.v значения находятся рядом с одним из следующих, которые я буду называть фокусами:

[1] -0.89115386 -0.75346155 -0.61576924 -0.47807693 -0.34038463 -0.20269232 -0.06500001 
[8] 0.07269230 0.21038460 0.34807691 0.48576922 0.62346153 0.76115383 0.89884614 

(The crime.v значения фактически средние значения 13 переменных, значения которых может находиться в диапазоне от -1 до 1, но которые в конечном итоге сходятся к значениям, которые находятся в окрестности 0,9 или -,9. Средние значения 13 значений около 0,9 или -,9 несколько близки к фокусам. На практике я определил соответствующие значения фокусов, изучив данные, так как есть некоторые дополнительные изменения.)

Скрипичный участок может быть изготовлен с:

require(lattice) 
bwplot(crime.v ~ bias, data=df30, ylim=c(-1,1), panel=panel.violin) 

Если вы запустите это с помощью большего набора данных, вы увидите, что один из созданных скриптовых графиков является мультимодальным, а другой - нет. Однако это не отражает разницу в данных, лежащих в основе двух скрипичных графиков; Насколько я могу судить, это артефакт из-за местоположения фокусов по отношению к сюжету. Я могу сгладить разницу, изменив параметры density, переданные панели panel.violin, но было бы проще указать, сколько очков в каждом кластере.

Спасибо!

Answer 1

Вот одна возможности, используя базовые графики:

tmp <- tapply(iris$Petal.Length, iris$Species, function(x) hist(x, plot=FALSE)) 

plot.new() 
tmp.r <- do.call(range, lapply(tmp, `[[`, 'breaks')) 
plot.window(xlim=c(1/2,length(tmp)+1/2), ylim=tmp.r) 
abline(v=seq_along(tmp)) 

for(i in seq_along(tmp)) { 
    h <- tmp[[i]] 
    rf <- h$counts/sum(h$counts) 
    rect(i-rf/2, head(h$breaks, -1), i+rf/2, tail(h$breaks, -1)) 
} 

axis(1, at=seq_along(tmp), labels=names(tmp)) 
axis(2) 
box() 

Вы можете настроить различные части с вашими предпочтениями, и все это может быть легко обернутой в функцию.

Answer 2

Это функция панели решетки, основанная на ответе @ GregSnow, с использованием базовой графики. Я не мог бы сделать это без того, чтобы Грег обеспечил прочную отправную точку, так что все кредиты идут на Грега.Моя функция панели не очень сложна и может очень хорошо прорваться на что-то простое, но будет обрабатывать горизонтальные и вертикальные ориентации и позволит вам снабдить вектор перерывов или оставить его. Он также удаляет ящики на концах, которые пусты. Функция панели использует hist по умолчанию для breaks, а не histogram, что сложнее. Комментарии о лучших методах приветствуются.

Поскольку симметричные или центрированные гистограммы не имеют имени, насколько я знаю, и они напоминают игрушку Tower of Hanoi, возможно, их следует называть гистограммой «Башня Ханой». Таким образом, функция называется panel.hanoi.

Простой пример использования с помощью определения df30 выше:

bwplot(crime.v ~ bias, data=df30, panel=panel.hanoi) 

Вот более сложный пример с использованием данных, представленных в ссылке в вопросе (графическому в конце ответа).

bwplot(crime.v ~ bias, data=df, ylim=c(-1,1), pch="|", coef=0, panel=function(...){panel.hanoi(col="pink", breaks=cv.ints, ...); panel.bwplot(...)}) 

Этот пример добавляет ylim указать, что сюжет должен идти от -1 до 1, и накладывает bwplot поверх участка Ханоя. pch и coef влияют на внешний вид bwplot. Этот пример также использует следующее определение для центрирования каждой коробки сюжета Ханоя вокруг места, где мои точки данных, как правило, лежат (см оригинального вопроса):

cv.ints <- c(-1.000000000, -0.960000012, -0.822307704, -0.684615396, -0.546923088, -0.409230781, -0.271538473, -0.133846165, 0.003846142, 0.141538450, 0.279230758, 0.416923065, 0.554615373, 0.692307681, 0.829999988, 0.967692296, 1.000000000) 

Вот функция панели:

panel.hanoi <- function(x, y, horizontal, breaks="Sturges", ...) { # "Sturges" is hist()'s default 

    if (horizontal) { 
    condvar <- y # conditioning ("independent") variable 
    datavar <- x # data ("dependent") variable 
    } else { 
    condvar <- x 
    datavar <- y 
    } 

    conds <- sort(unique(condvar)) 

    # loop through the possible values of the conditioning variable 
    for (i in seq_along(conds)) { 

     h <- hist(datavar[condvar == conds[i]], plot=F, breaks) # use base hist(ogram) function to extract some information 

    # strip outer counts == 0, and corresponding bins 
    brks.cnts <- stripOuterZeros(h$breaks, h$counts) 
    brks <- brks.cnts[[1]] 
    cnts <- brks.cnts[[2]] 

    halfrelfs <- (cnts/sum(cnts))/2 # i.e. half of the relative frequency 
    center <- i 

    # All of the variables passed to panel.rec will usually be vectors, and panel.rect will therefore make multiple rectangles. 
    if (horizontal) { 
     panel.rect(head(brks, -1), center - halfrelfs, tail(brks, -1), center + halfrelfs, ...) 
    } else { 
     panel.rect(center - halfrelfs, head(brks, -1), center + halfrelfs, tail(brks, -1), ...) 
    } 
    } 
} 

# function to strip counts that are all zero on ends of data, along with the corresponding breaks 
stripOuterZeros <- function(brks, cnts) { do.call("stripLeftZeros", stripRightZeros(brks, cnts)) } 

stripLeftZeros <- function(brks, cnts) { 
    if (cnts[1] == 0) { 
    stripLeftZeros(brks[-1], cnts[-1]) 
    } else { 
    list(brks, cnts) 
    } 
} 

stripRightZeros <- function(brks, cnts) { 
    len <- length(cnts) 
    if (cnts[len] ==0) { 
    stripRightZeros(brks[-(len+1)], cnts[-len]) 
    } else { 
    list(brks, cnts) 
    } 
}