Возможен ли многократный клип на сюжете?

Question

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

У меня есть следующие данные:

x=c(1,2,7,3,4,8,9,5,6,7,11,13,15,8,9,10,11,12,13,15)
y=c(2:10,9,8,7,6,8,10,11,12,13,14,1)
date=strptime(20010101:20010120,'%Y%m%d')
z=data.frame(date,x,y)
z$diff=z$y-z$x
z$min=pmin(x,y)
z$max=pmax(x,y)

Итак, мои данные таковы:

         date  x  y diff min max
1  2001-01-01  1  2    1   1   2
2  2001-01-02  2  3    1   2   3
3  2001-01-03  7  4   -3   4   7
4  2001-01-04  3  5    2   3   5
5  2001-01-05  4  6    2   4   6
6  2001-01-06  8  7   -1   7   8
7  2001-01-07  9  8   -1   8   9
8  2001-01-08  5  9    4   5   9
9  2001-01-09  6 10    4   6  10
10 2001-01-10  7  9    2   7   9
11 2001-01-11 11  8   -3   8  11
12 2001-01-12 13  7   -6   7  13
13 2001-01-13 15  6   -9   6  15
14 2001-01-14  8  8    0   8   8
15 2001-01-15  9 10    1   9  10
16 2001-01-16 10 11    1  10  11
17 2001-01-17 11 12    1  11  12
18 2001-01-18 12 13    1  12  13
19 2001-01-19 13 14    1  13  14
20 2001-01-20 15  1  -14   1  15

Я хочу создать полигональную диаграмму, в которой цвет полигона изменяется в зависимости от того, когда z $ diff меньше нуля.Таким образом, график должен выглядеть следующим образом:

Я знаю, что сегменты могут делать это с помощью линий, но, к сожалению, мне нужно сделать это с помощью многоугольника.

Исходное сообщение:

Допустим, у меня есть эти данные:

x=rnorm(100)
y=rnorm(100)
date=strptime(20010101:20010410,'%Y%m%d')
date=date[complete.cases(date)]
z=data.frame(date,x,y)
z$max=apply(z[2:3],1,which.max)
z$min=apply(z[2:3],1,which.min)
z$v=z$max-z$min
w=z[z$v<0,]

Затем я пытаюсь создать многоугольник, состоящий из двух цветов: один для случаев, когда x> y, а другой для случая, когда y> х.Я делаю это:

plot(z$date,z$x,type='n')
polygon(c(z$date,z$date[nrow(z):1]),c(z$x,z$y[nrow(z):1]),col='skyblue',border=NA)
polygon(c(w$date,w$date[nrow(w):1]),c(w$x,w$y[nrow(w):1]),col='salmon',border=NA)

Что происходит, когда во фрейме данных есть пробелы w, полигон покрывает эти пробелы.Я знаю, как использовать обрезку для обрезки одной области, но можно ли ее использовать для обрезки нескольких пробелов во фрейме данных?

В идеале многоугольник w должен перекрывать многоугольник z всякий раз, когда y> x.

Answer 1

Полигоны можно разделять линией в данных, состоящей только из NA.

library(reshape2)
library(ggplot2)

z <- data.frame(
    date=date,
    min=pmin(x, y),
    max=pmax(x, y),
    series=ifelse(x>y, 1, 2)
)

# Helper function to create closed polygon, optionally adding NA line at bottom
rdata <- function(dat, addNA=FALSE){
  rdat <- dat[nrow(dat):1, ]
  ret <- rbind(
      data.frame(x= dat$date, y= dat$max, series= dat$series), 
      data.frame(x=rdat$date, y=rdat$min, series=rdat$series)
  )
  if(addNA) ret <- rbind(ret, c(NA, NA, NA))
  ret
}

# Closed polygon 1
rz <- rdata(z)

#Closed polygon 2
z2 <- z
rlez <- rle(z$series)$lengths
z2$chunk <- rep(seq_along(rlez), times=rlez)
rz2 <- ddply(z2, .(chunk), rdata, addNA=TRUE)
rz2 <- rz2[rz2$series!=1, ]

Создать сюжет

ggplot(rz, aes(x, y, fill="Less than")) + geom_polygon() + 
    geom_polygon(data=rz2, aes(x, y, fill="Greater than")) +
    scale_fill_discrete("Legend") +
    xlab("Date") +
    ylab("Value")

---

PS. Я не знаю, что ваши данные представляют в реальной жизни, но я догадываюсь, что вы можете визуализировать их лучше (или, по крайней мере, также), с гораздо меньшими усилиями, если вы используете geom_linerange вместо полигонов.

ggplot(z, aes(x=date, ymin=min, ymax=max, colour=factor(series))) + 
    geom_linerange(size=5)

Answer 2

Направление, отличное от того, которое взял @Andrie. Я нашел более интуитивно понятным использование geom_ribbon (что, я уверен, на каком-то уровне является просто оболочкой для geom_polygon).

Вы не очень хорошо указали, что делать с кусками длины один. Технически, «полигон» для такого куска будет просто вертикальным отрезком. Мне показалось более интуитивно понятным, что эти куски слегка вытянуты в любом направлении, чтобы «встретиться посередине».

#Construct similar data
x=c(1,2,7,3,4,8,9,5,6,7,11,13,15,8,9,10,11,12,13,15)
y=c(2:10,9,8,7,6,8,10,11,12,13,14,1)
date=strptime(20010101:20010120,'%Y%m%d')
z=data.frame(date,x,y)
z$diff=z$y-z$x
z$min=pmin(x,y)
z$max=pmax(x,y)

#Assign a unique integer to each chunk
tmp <- rle(z$diff > 0)
z$series <- rep(1:length(tmp$lengths),times = tmp$lengths)

#Grab just the useful columns
z1 <- z[,c(1,4:7)]

#This is the ugly part.
# Loop through data and add a row
# at the transitions    
for (i in 2:nrow(z1)){
    if (z1$series[i] != z1$series[i-1]){
        newRow <- colwise(mean)(z1[c(i,i-1),])
        newRow1 <- newRow2 <- newRow
        newRow1$series <- z1$series[i-1]; newRow2$series <- z1$series[i]
        newRow1$diff <- z1$diff[i-1]; newRow2$diff <- z1$diff[i]
        z1 <- rbind(z1,newRow1,newRow2)
    }
}

#Put everything back in order
z1 <- arrange(z1,date)

#Create a factor to build the legend with
z1$diff <- sign(z1$diff)
z1$grp <- factor(ifelse(z1$diff > 0,"Greater Than","Less Than"))

#The only clever bit ;)
ribbons <- dlply(z1,.(series),.fun = function(x){geom_ribbon(data = x,aes(ymin = min,ymax = max,fill = grp))})

p <- ggplot(z1,aes(x = date, ymin = min,ymax = max,fill = grp)) +
        ribbons + 
        labs(x = NULL,y = NULL,fill = "Legend")

Это, очевидно, имеет некоторые недостатки:

1. Предполагается, что усреднение значений x и y является разумным. Работал с POSIXct, но, вероятно, не с чистыми датами!
2. Если вы не хотите, чтобы фрагменты «разделяли разницу» на границах фрагментов, превышающих один день, вам придется немного поиграться в цикле for, чтобы посмотреть в будущее и посмотреть, как долго каждый блок есть.

Я вообще не убирал это, так что я уверен, что улучшения возможны ...

Answer 3

Сегодня я поиграл с этим, чтобы посмотреть, возможен ли элегантный базовый подход к гистограмме в ответе Андри .Вот простой подход в базе:

x=c(1,2,7,3,4,8,9,5,6,7,11,13,15,8,9,10,11,12,13,15)
y=c(2:10,9,8,7,6,8,10,11,12,13,14,1)
date=strptime(20010101:20010120,'%Y%m%d')
z=data.frame(date,x,y)
z$diff=z$y-z$x
z$min=pmin(x,y)
z$max=pmax(x,y)

zp=z[z$diff>0,]
zn=z[z$diff<0,]

plot(z$date,z$max,type='n',ylim=range(0,max(z$max)))
segments(zp$date,zp$min,zp$date,zp$max,col='skyblue',lwd=10,lend=1)
segments(zn$date,zn$min,zn$date,zn$max,col='salmon',lwd=10,lend=1)

Answer 4

Я предлагаю вам объединить все данные в одном фрейме данных с разными именами столбцов для z и w.

names(w) <- c('date1','x1','y1','max1','min1','v1')
kk <- merge(z,w, by.x='date', by.y='date1', all.x=TRUE)

plot(kk$date,kk$x,type='n')
polygon(c(kk$date,kk$date[nrow(kk):1]),c(kk$x,kk$y[nrow(kk):1])
        ,col='skyblue',border=NA)
polygon(c(kk$date,kk$date[nrow(kk):1]), c(kk$x1,kk$y1[nrow(kk):1])
        ,col='salmon',border=NA)