Come riempire geom_polygon con colors diversi sopra e sotto y = 0?

Considerando il seguente grafico poligonale:

ggplot(df, aes(x=year,y=afw)) + geom_polygon() + scale_x_continuous("", expand=c(0,0), breaks=seq(1910,2010,10)) + theme_bw() 

inserisci la descrizione dell'immagine qui

Tuttavia, voglio riempirlo con due colors diversi. Ad esempio rosso per le aree nere sopra 0 e blu per le aree nere sotto 0 . Sfortunatamente, l’uso di fill=col non riempie le aree corrette.

Ho provato il seguente codice (ho aggiunto la geom_line per illustrare dove dovrebbe essere il bordo del riempimento):

 ggplot(df, aes(x=year,y=afw)) + geom_line() + geom_polygon(aes(fill=col), alpha=0.5) + scale_x_continuous("", expand=c(0,0), breaks=seq(1910,2010,10)) + theme_bw() 

che dà: inserisci la descrizione dell'immagine qui

Come puoi vedere, sta riempiendo molto più di quanto dovrebbe fare. Come posso risolvere questo?

I dati:

 df <- structure(list(year = c(1901, 1901, 1901, 1902, 1903, 1904, 1905, 1906, 1907, 1908, 1909, 1910, 1911, 1912, 1913, 1914, 1915, 1916, 1917, 1918, 1919, 1920, 1921, 1922, 1923, 1924, 1925, 1926, 1927, 1928, 1929, 1930, 1931, 1932, 1933, 1934, 1935, 1936, 1937, 1938, 1939, 1940, 1941, 1942, 1943, 1944, 1945, 1946, 1947, 1948, 1949, 1950, 1951, 1952, 1953, 1954, 1955, 1956, 1957, 1958, 1959, 1960, 1961, 1962, 1963, 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 1974, 1975, 1976, 1977, 1978, 1979, 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2013, 2013), afw = c(0, 0, -0.246246074793035, -2.39463317156723, -2.39785897801884, 0.840850699400514, -0.843020268341422, -3.02043962318013, -0.033342848986583, -2.04947188124465, -0.00431059092206709, 2.49568940907793, 1.96988295746503, 2.26665715101342, 0.986011989723095, 1.79568940907793, 2.06665715101342, -0.601084784470454, -3.21076220382529, 2.65052811875535, 0.46988295746503, -1.09140736511562, 0.0505281187553526, 1.41827005423922, -2.80108478447045, 0.611818441335997, -1.83011704253497, -0.30753639737368, -4.43011704253497, -0.897858978018841, 1.98601198972309, -0.965600913502712, 0.0795603768198685, 0.308592634884385, -5.33011704253497, 4.00214102198116, -0.594633171567228, 0.0698829574650297, -1.60753639737368, -2.81398801027691, -2.21398801027691, -2.4365686554382, 1.53439908649729, 1.06665715101342, -1.87205252640594, -0.688181558664002, 0.0569797316585783, -3.51398801027691, 0.979560376819868, 0.289237796174707, 1.24085069940051, -4.39140736511562, 1.13117328004567, -1.72689123608336, 2.20214102198116, 2.27310876391664, 1.46665715101342, 2.18278618327148, -0.23011704253497, 1.50536682843277, 1.17633457036826, -0.0785041393091639, -1.54947188124465, -3.85269768769626, -4.31398801027691, -0.80753639737368, 1.27956037681987, 1.2376248929489, 0.195689409077933, -3.38172994576078, -4.88172994576078, -0.675278332857551, 2.25375392520697, 0.0924636026263199, -0.446246074793035, 4.06988295746503, 0.350528118755352, -1.48172994576078, 1.81504424778761, -1.42689123608336, 2.22472166714245, 0.376334570368256, -3.88495575221239, 0.211818441335998, 0.586011989723094, 1.14407650585213, 2.55697973165858, 1.92794747359406, 1.20214102198116, 3.83439908649729, 1.64407650585213, 0.986011989723095, 0.753753925206965, 0.508592634884385, 1.911818441336, 2.11504424778761, -4.06560091350271, -2.58495575221239, 1.80859263488438, 1.37956037681987, 1.58923779617471, 1.88601198972309, -0.323665429631744, -0.291407365115615, 0.818270054239223, 0.0569797316585783, 0.795689409077933, 3.32472166714245, 0.595689409077933, -0.733342848986583, -0.955923494147874, -4.32689123608336, 3.29891521552955, 1.85697973165858, 2.74407650585213, 0, 0), col = structure(c(1L, 2L, 1L, 1L, 1L, 2L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 1L, 1L, 1L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 1L, 2L, 1L, 1L, 1L, 1L, 2L, 2L, 1L, 1L, 2L, 1L, 2L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 2L, 2L, 1L, 2L, 2L, 1L, 1L, 1L, 1L, 1L, 2L, 2L, 2L, 1L, 1L, 1L, 2L, 2L, 1L, 2L, 2L, 1L, 2L, 1L, 2L, 2L, 1L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 1L, 1L, 2L, 2L, 2L, 2L, 2L, 1L, 1L, 1L, 2L, 2L, 2L, 2L, 1L), .Label = c("B", "A"), class = "factor")), .Names = c("year", "afw", "col"), class = c("tbl_df", "data.frame"), row.names = c(NA, -117L)) 

Nota: come potete vedere nei dati, ci sono 3 righe sia per il 1901 che per il 2013. L’ho fatto perché volevo ottenere il riempimento corretto. Sebbene il riempimento nero sia corretto, non mi sembra di avere una soluzione funzionante con i colors.

Il set di dati originale:

 orig <- structure(list(year = c(1901, 1902, 1903, 1904, 1905, 1906, 1907, 1908, 1909, 1910, 1911, 1912, 1913, 1914, 1915, 1916, 1917, 1918, 1919, 1920, 1921, 1922, 1923, 1924, 1925, 1926, 1927, 1928, 1929, 1930, 1931, 1932, 1933, 1934, 1935, 1936, 1937, 1938, 1939, 1940, 1941, 1942, 1943, 1944, 1945, 1946, 1947, 1948, 1949, 1950, 1951, 1952, 1953, 1954, 1955, 1956, 1957, 1958, 1959, 1960, 1961, 1962, 1963, 1964, 1965, 1966, 1967, 1968, 1969, 1970, 1971, 1972, 1973, 1974, 1975, 1976, 1977, 1978, 1979, 1980, 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013), afw = c(-0.246246074793035, -2.39463317156723, -2.39785897801884, 0.840850699400514, -0.843020268341422, -3.02043962318013, -0.033342848986583, -2.04947188124465, -0.00431059092206709, 2.49568940907793, 1.96988295746503, 2.26665715101342, 0.986011989723095, 1.79568940907793, 2.06665715101342, -0.601084784470454, -3.21076220382529, 2.65052811875535, 0.46988295746503, -1.09140736511562, 0.0505281187553526, 1.41827005423922, -2.80108478447045, 0.611818441335997, -1.83011704253497, -0.30753639737368, -4.43011704253497, -0.897858978018841, 1.98601198972309, -0.965600913502712, 0.0795603768198685, 0.308592634884385, -5.33011704253497, 4.00214102198116, -0.594633171567228, 0.0698829574650297, -1.60753639737368, -2.81398801027691, -2.21398801027691, -2.4365686554382, 1.53439908649729, 1.06665715101342, -1.87205252640594, -0.688181558664002, 0.0569797316585783, -3.51398801027691, 0.979560376819868, 0.289237796174707, 1.24085069940051, -4.39140736511562, 1.13117328004567, -1.72689123608336, 2.20214102198116, 2.27310876391664, 1.46665715101342, 2.18278618327148, -0.23011704253497, 1.50536682843277, 1.17633457036826, -0.0785041393091639, -1.54947188124465, -3.85269768769626, -4.31398801027691, -0.80753639737368, 1.27956037681987, 1.2376248929489, 0.195689409077933, -3.38172994576078, -4.88172994576078, -0.675278332857551, 2.25375392520697, 0.0924636026263199, -0.446246074793035, 4.06988295746503, 0.350528118755352, -1.48172994576078, 1.81504424778761, -1.42689123608336, 2.22472166714245, 0.376334570368256, -3.88495575221239, 0.211818441335998, 0.586011989723094, 1.14407650585213, 2.55697973165858, 1.92794747359406, 1.20214102198116, 3.83439908649729, 1.64407650585213, 0.986011989723095, 0.753753925206965, 0.508592634884385, 1.911818441336, 2.11504424778761, -4.06560091350271, -2.58495575221239, 1.80859263488438, 1.37956037681987, 1.58923779617471, 1.88601198972309, -0.323665429631744, -0.291407365115615, 0.818270054239223, 0.0569797316585783, 0.795689409077933, 3.32472166714245, 0.595689409077933, -0.733342848986583, -0.955923494147874, -4.32689123608336, 3.29891521552955, 1.85697973165858, 2.74407650585213)), .Names = c("year", "afw"), class = c("tbl_df", "data.frame"), row.names = c(NA, -113L)) 

Ecco una possibilità adattata dalla risposta di @kohske qui . Tutti i crediti per lui. Ulteriori punti dati sono generati dall’interpolazione lineare e la trama viene eseguita da geom_area .

Innanzitutto, un esempio più piccolo per rendere più facile l’impressione dell’interpolazione lineare e quali punti vengono aggiunti ai dati originali:

 # original data d <- data.frame(x = c(1:6), y = c(-1, 2, 1, 2, -1, 1)) # add a grouping variable just to keep track of original and interpolated points d$grp <- "orig" # create interpolated points d <- d[order(d$x),] new_d <- do.call("rbind", sapply(1:(nrow(d) -1), function(i){ f <- lm(x ~ y, d[i:(i+1), ]) if (f$qr$rank < 2) return(NULL) r <- predict(f, newdata = data.frame(y = 0)) if(d[i, ]$x < r & r < d[i+1, ]$x) return(data.frame(x = r, y = 0)) else return(NULL) }) ) new_d$grp <- "new" # combine original and interpolated data d2 <- rbind(d, new_d) d2 # xy grp # 1 1.000000 -1 orig # 2 2.000000 2 orig # 3 3.000000 1 orig # 4 4.000000 2 orig # 5 5.000000 -1 orig # 6 6.000000 1 orig # 13 1.333333 0 new # 11 4.666667 0 new # 12 5.500000 0 new # similar plot as below, but points are added, with different color (original vs new) ggplot(data = d2, aes(x = x, y = y)) + geom_area(data = subset(d2, y <= 0), fill = "red", alpha = 0.2) + geom_area(data = subset(d2, y >= 0), fill = "blue", alpha = 0.2) + geom_point(aes(color = grp), size = 10) + theme_bw() 

inserisci la descrizione dell'immagine qui

I tuoi dati:

 orig <- orig[order(orig$year), ] rx <- do.call("rbind", sapply(1:(nrow(orig) - 1), function(i){ f <- lm(year ~ afw, orig[i:(i+1), ]) if (f$qr$rank < 2) return(NULL) r <- predict(f, newdata = data.frame(afw = 0)) if(orig[i, ]$year < r & r < orig[i + 1, ]$year) return(data.frame(year = r, afw = 0)) else return(NULL) }) ) d2 <- rbind(orig, rx) ggplot(d2, aes(x = year, y = afw)) + geom_area(data = subset(d2, afw <= 0), fill = "red") + geom_area(data = subset(d2, afw >= 0), fill = "blue") + scale_x_continuous("", expand = c(0,0), breaks = seq(1910, 2010, 10)) + theme_bw() 

inserisci la descrizione dell'immagine qui

Quindi questo non è perfetto e sono interessato a vedere cosa gli altri escono con …

La ragione per le aree colorate “multiple” è che un singolo poligono è limitato dai punti dati e che i punti dati non sono effettivamente zero.

Per risolvere questo, possiamo interpolare usando approx() . Per una soluzione perfetta, è necessario determinare esattamente dove la linea incrocia zero.

 interp <- approx(orig$year, orig$afw, n=10000) orig2 <- data.frame(year=interp$x, afw=interp$y) orig2$col[orig2$afw >= 0] <- "pos" orig2$col[orig2$afw < 0] <- "neg" ggplot(orig2, aes(x=year, y=afw)) + geom_area(aes(fill=col)) + geom_line() + geom_hline(yintercept=0) 

Soluzione

Tuttavia, vedrai che questo ha ancora problemi durante lo zoom:

Zoomed


Per approfondire la mia affermazione sopra (e illustrare ulteriormente il "problema / problema" originale), considera ciò che accade quando elimini separatamente ciascuno dei set di dati positivi e negativi originali:

 p1 <- ggplot(subset(orig, col == "neg"), aes(x = year, y = afw)) + geom_area(aes(fill=col)) + scale_fill_manual(values = c("#FF3030", "#00CC66")) p2 <- ggplot(subset(orig, col == "pos"), aes(x = year, y = afw)) + geom_area(aes(fill=col)) + scale_fill_manual(values = c("#00CC66", "#FF3030")) library(gridExtra) grid.arrange(p2, p1) 

Plot multipli


Ovviamente, puoi sempre risolvere questo problema utilizzando un diverso tipo di visualizzazione:

 ggplot(data = orig, aes(x = year, y = afw)) + geom_bar(stat = "identity", aes(fill=col), colour = "white") 

Soluzione alternativa