आर: सशर्त रंग

Question

के साथ एक बहुभुज ड्रा करें मैं एक वक्र के नीचे क्षेत्र को रंगना चाहता हूं। Y> 0 वाला क्षेत्र लाल होना चाहिए, y < 0 वाला क्षेत्र हरा होना चाहिए।

x <- c(1:4) 
y <- c(0,1,-1,2,rep(0,4)) 
plot(y[1:4],type="l") 
abline(h=0) 

काम नहीं करता है ifelse() का उपयोग करना:

polygon(c(x,rev(x)),y,col="green") 
polygon(c(x,rev(x)),ifelse(y>0,y,0),col="red") 

लेकिन फिर लाल क्षेत्र बहुत बड़ा है:

polygon(c(x,rev(x)),y,col=ifelse(y>0,"red","green")) 

मैं अब तक क्या हासिल निम्नलिखित है। क्या आपके पास कोई वांछित परिणाम प्राप्त करने के बारे में कोई विचार है?

Answer 1

यदि आप दो अलग-अलग रंग चाहते हैं, तो आपको दो अलग-अलग बहुभुज की आवश्यकता है। आप या तो बहुभुज को कई बार कॉल कर सकते हैं, या आप अपने x और y वैक्टरों में NA वैल्यू जोड़ सकते हैं ताकि एक नया बहुभुज इंगित किया जा सके। आर स्वचालित रूप से आपके लिए छेड़छाड़ की गणना नहीं करेगा। आपको वह खुद करना होगा। यहां बताया गया है कि आप इसे विभिन्न रंगों से कैसे आकर्षित कर सकते हैं।

x <- c(1,2,2.5,NA,2.5,3,4) 
y <- c(0,1,0,NA,0,-1,0) 

#calculate color based on most extreme y value 
g <- cumsum(is.na(x)) 
gc <- ifelse(tapply(y, g, 
    function(x) x[which.max(abs(x))])>0, 
    "red","green") 

plot(c(1, 4),c(-1,1), type = "n") 
polygon(x, y, col = gc) 
abline(h=0) 

अधिक सामान्य मामले में, यह अलग-अलग क्षेत्रों में एक बहुभुज विभाजित करने के लिए के रूप में आसान नहीं हो सकता है। जीआईएस पैकेज में इस प्रकार के ऑपरेशन के लिए कुछ समर्थन प्रतीत होता है, जहां इस तरह की चीज अधिक आम है। हालांकि, मैंने कुछ सामान्य मामला एक साथ रखा है जो साधारण बहुभुज के लिए काम कर सकता है।

सबसे पहले, मैं एक बंद करने को परिभाषित करता हूं जो एक काटने की रेखा को परिभाषित करेगा। फ़ंक्शन एक रेखा के लिए एक ढलान और वाई-अवरोध लेगा और बहुभुज को काटने के लिए आवश्यक कार्यों को वापस कर देगा।

getSplitLine <- function(m=1, b=0) { 
    force(m); force(b) 
    classify <- function(x,y) { 
     y >= m*x + b 
    } 
    intercepts <- function(x,y, class=classify(x,y)) { 
     w <- which(diff(class)!=0) 
     m2 <- (y[w+1]-y[w])/(x[w+1]-x[w]) 
     b2 <- y[w] - m2*x[w] 

     ix <- (b2-b)/(m-m2) 
     iy <- ix*m + b 
     data.frame(x=ix,y=iy,idx=w+.5, dir=((rank(ix, ties="first")+1) %/% 2) %% 2 +1) 
    } 
    plot <- function(...) { 
    abline(b,m,...) 
    } 
    list(
     intercepts=intercepts, 
     classify=classify, 
     plot=plot 
    ) 
} 

अब हम वास्तव में परिभाषित स्प्लिटर का उपयोग करके बहुभुज को विभाजित करने के लिए एक फ़ंक्शन को परिभाषित करेंगे।

splitPolygon <- function(x, y, splitter) { 
    addnullrow <- function(x) if (!all(is.na(x[nrow(x),]))) rbind(x, NA) else x 
    rollup <- function(x,i=1) rbind(x[(i+1):nrow(x),], x[1:i,]) 
    idx <- cumsum(is.na(x) | is.na(y)) 
    polys <- split(data.frame(x=x,y=y)[!is.na(x),], idx[!is.na(x)]) 
    r <- lapply(polys, function(P) { 
     x <- P$x; y<-P$y 
     side <- splitter$classify(x, y) 
     if(side[1] != side[length(side)]) { 
      ints <- splitter$intercepts(c(x,x[1]), c(y, y[1]), c(side, side[1])) 
     } else { 
      ints <- splitter$intercepts(x, y, side) 
     } 
     sideps <- lapply(unique(side), function(ss) { 
      pts <- data.frame(x=x[side==ss], y=y[side==ss], 
       idx=seq_along(x)[side==ss], dir=0) 
      mm <- rbind(pts, ints) 
      mm <- mm[order(mm$idx), ] 
      br <- cumsum(mm$dir!=0 & c(0,head(mm$dir,-1))!=0 & 
       c(0,diff(mm$idx))>1) 
      if (length(unique(br))>1) { 
       mm<-rollup(mm, sum(br==br[1])) 
      } 
      br <- cumsum(c(FALSE,abs(diff(mm$dir*mm$dir))==3)) 
      do.call(rbind, lapply(split(mm, br), addnullrow)) 
     }) 
     pss<-rep(unique(side), sapply(sideps, nrow)) 
     ps<-do.call(rbind, lapply(sideps, addnullrow))[,c("x","y")] 
     attr(ps, "side")<-pss 
     ps 
    }) 
    pss<-unname(unlist(lapply(r, attr, "side"))) 
    src <- rep(seq_along(r), sapply(r, nrow)) 
    r <- do.call(rbind, r) 
    attr(r, "source")<-src 
    attr(r, "side")<-pss 
    r 
} 

इनपुट के रूप में आप कटर के साथ polygon के पास चला जाएगा बस x और y के मूल्यों है। यह x और y मानों के साथ डेटा.फ्रेम लौटाएगा जिसका उपयोग polygon के साथ किया जा सकता है।

उदाहरण

लिए

x <- c(1,2,2.5,NA,2.5,3,4) 
y <- c(1,-2,2,NA,-1,2,-2) 

sl<-getSplitLine(0,0) 

plot(range(x, na.rm=T),range(y, na.rm=T), type = "n") 
p <- splitPolygon(x,y,sl) 
g <- cumsum(c(F, is.na(head(p$y,-1)))) 
gc <- ifelse(attr(p,"side")[is.na(p$y)], 
    "red","green") 
polygon(p, col=gc) 
sl$plot(lty=2, col="grey") 

यह सरल अवतल बहुभुज के साथ-साथ sloped लाइनों के लिए काम करना चाहिए। यहाँ एक और उदाहरण

x <- c(1,2,3,4,5,4,3,2) 
y <- c(-2,2,1,2,-2,.5,-.5,.5) 

sl<-getSplitLine(.5,-1.25) 

plot(range(x, na.rm=T),range(y, na.rm=T), type = "n") 
p <- splitPolygon(x,y,sl) 
g <- cumsum(c(F, is.na(head(p$y,-1)))) 
gc <- ifelse(attr(p,"side")[is.na(p$y)], 
    "red","green") 
polygon(p, col=gc) 
sl$plot(lty=2, col="grey") 

अभी जब बहुभुज के शिखर बंटवारे लाइन पर सीधे गिर जाता है चीज़ें थोड़ी गन्दा प्राप्त कर सकते हैं। मैं भविष्य में इसे सही करने की कोशिश कर सकता हूं।