Cómo rellenar geom_polygon con diferentes colores por encima y por debajo de y = 0?

Teniendo en cuenta el siguiente diagtwig de polígono:

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

enter image description here

Sin embargo, quiero llenar esto con dos colores diferentes. Por ejemplo, rojo para las áreas negras por encima de 0 y azul para las áreas negras por debajo de 0 . Desafortunadamente, usar fill=col no llena las áreas correctas.

geom_line el siguiente código (agregué el geom_line para ilustrar dónde debería estar el borde del relleno):

 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() 

lo que da: enter image description here

Como puede ver, está llenando mucho más de lo que se supone que debe hacer. ¿Como puedo resolver esto?

Los datos:

 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: como puede ver en los datos, hay 3 filas tanto para 1901 como para 2013. Hice esto porque quería llenarlo correctamente. Aunque el relleno negro es correcto, parece que no obtengo una solución funcional con colores.

El conjunto de datos original:

 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)) 

Aquí hay una posibilidad adaptada de la respuesta de @ kohske aquí . Todos los créditos para él. Los puntos de datos adicionales se generan por interpolación lineal, y el diagtwig está hecho por geom_area .

Primero, un ejemplo más pequeño para que sea más fácil obtener una idea de la interpolación lineal y qué puntos se agregan a los datos originales:

 # 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() 

enter image description here

Tu información:

 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() 

enter image description here

Entonces, esto no es perfecto y me interesa ver qué se les ocurre a los demás …

La razón para las áreas de color “múltiples” es que un solo polígono está delimitado por los puntos de datos y los puntos de datos no son realmente cero.

Para resolver esto, podemos interpolar utilizando approx() . Para una solución perfecta, necesitaría determinar exactamente dónde cruza la línea cero.

 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) 

Solución

Sin embargo, verá que esto todavía tiene problemas cuando hace zoom:

Zoomed


Para profundizar en mi afirmación anterior (e ilustrar aún más el "problema / problema" original), considere lo que sucede cuando traza cada uno de los conjuntos de datos positivos y negativos originales por separado:

 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) 

Parcelas múltiples


Por supuesto, siempre puedes resolver esto utilizando un tipo diferente de visualización:

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

Solución Alternativa