R/mapz.mrp.R

In MrPzurich2013: MrP functions for MA class Zurich 2013

mapz.mrp <-
function(x, colors.m, threshold, main, legend.text1, legend.text2, ...){
    k <- 200
		if(missing(main)) main <- ""
		if(missing(legend.text1)) legend.text1 <- ""
		if(missing(legend.text2)) legend.text2 <- ""
		if(missing(colors.m))  	colors.m <- c(rgb(165,0,38,k,maxColorValue=255),rgb(215, 48,39,k,maxColorValue=255), rgb(244, 109, 67,k,maxColorValue=255), rgb(253, 174, 97,k,maxColorValue=255), rgb(254, 224, 139,k,maxColorValue=255), rgb(217, 239, 139,k,maxColorValue=255), rgb(166, 217, 106,k,maxColorValue=255), rgb(102, 189, 99,k,maxColorValue=255), rgb(26, 152, 80,k,maxColorValue=255),rgb(0, 104, 55,k,maxColorValue=255))
		#if(missing(threshold)) flag.legend <- 1
    if(missing(threshold)) threshold <- seq(0,1,by=1/(length(colors.m)))
    
    
    # packages
		#library(maptools)

		# reading-in shape files
		#data("zip1.rda")
		KT <- zip1$KT
		data.in <- cbind(x,c(1:26))
		data1 <- data.in[KT,]
		zip1$data <- data1

		#colors.m <- c("0xD73027","0xF46D43", "0xFDAE61","0xFEE08B","0xFFFFBF","0xD9EF8B","0xA6D96A","0x66BD63","0x1A9850")


			
		#colors.m <- c(rgb(165,0,38,k,maxColorValue=255),rgb(215, 48,39,k,maxColorValue=255), rgb(244, 109, 67,k,maxColorValue=255), rgb(253, 174, 97,k,maxColorValue=255), rgb(254, 224, 139,k,maxColorValue=255), rgb(217, 239, 139,k,maxColorValue=255), rgb(166, 217, 106,k,maxColorValue=255), rgb(102, 189, 99,k,maxColorValue=255), rgb(26, 152, 80,k,maxColorValue=255),rgb(0, 104, 55,k,maxColorValue=255))
		
		#threshold <- c(0,10,20,30,40,50,60,70,80,90,100)/100
		col.pointer <- rep(NA,26)
		
		for (i in 1:26){
				col.pointer[i] <- max(which(zip1$data[i,1]>threshold))
				}
	
	#par(mai=c(0,0,0,0))
	plot(zip1, col= colors.m[col.pointer], main=main, ...)
	title(main=main, line=2)
  
  # legend
  if (missing(threshold)==TRUE){
    l.number <- ceiling((length(colors.m))/2)
    r.number <- (length(colors.m))-l.number
    lab1 <- c(NA)
    for (i in 1:l.number){
      step <- 1/(length(colors.m))
      a <- 0 + (i-1)*step
      b <- step*i
      lab1 <- c(lab1,paste(round(100*a,0),"-",round(100*b,0),"%",sep=""))
      if(i==l.number) lab1 <- lab1[-1]
    }
    
    lab2 <- c(NA)
    for (i in 1:r.number){
      step <- 1/(length(colors.m))
      a <- 0 + (l.number + i-1)*step
      b <- step*(l.number +i)
      lab2 <- c(lab2,paste(round(100*a,0),"-",round(100*b,0),"%",sep=""))
      if(i==r.number) lab2 <- lab2[-1]
    }
  }
    
		if(missing(threshold)==FALSE){
      l.number <- ceiling((length(threshold)-1)/2)
      r.number <- length(threshold)-l.number -1      
      lab1 <- c(NA)
      for (i in 1:l.number){
        a <- i
        b <- i+1
        lab1 <- c(lab1,paste(round(100*threshold[a],0),"-",round(100*threshold[b],0),"%",sep=""))
        if(i==l.number) lab1 <- lab1[-1]
      }
      lab2 <- c(NA)    
      for (i in (l.number+1):(l.number+r.number)){
        a <- i
        b <- i+1
        lab2 <- c(lab2,paste(round(100*threshold[a],0),"-",round(100*threshold[b],0),"%",sep=""))
        if(i==(r.number+l.number-1)) lab2 <- lab2[-1]
      }
		
		}  
	legend(x=490577,y=104297, legend=lab1, fill=colors.m[1:l.number], bty="n", xpd=NA)
	legend(x=750577,y=104297,legend=lab2, fill=colors.m[(l.number+1):(l.number+r.number)], bty="n", xpd=NA)
	text(660000,74297,legend.text1, xpd=NA)
	text(660000,63297,legend.text2, xpd=NA)
	}