自分のための「便利な自作関数」

このページのソースコードは、私がブログを書くために作ったもの。

使いたい人は勝手に使っても良いけれど、使用は自己責任で。バグがあるかも。

サポートに関しては、その時の気分次第。時間と心とお金に余裕があれば…。
ということで、返事が無くても怒らないように。疑問はコメント欄に。

今回のサンプルデータは以下の場所に。
https://docs.google.com/folder/d/0B9OtIs5BjRVhWm8zV1hCUFh6YnM/edit

以下からRの実行コード。

---

# Read a shape file.
X.geo <- readShapePoly('/home/yufujimoto/Desktop/japan.shp')

par(mfrow=c(1, 3),mar=c(2, 1, 4, 1))
cis.choropleth(X.geo, zcol="OCU", formula="scott", main="Number of Occupied Buildings")
cis.choropleth(X.geo, zcol="UNO", formula="scott", main="Number of Unoccupied Buildings")
cis.choropleth(X.geo, zcol="PRI", formula="scott", main="Average Buildings Rental Prices (Monthly)")

以下がRのソースコード。

---

# ======================================================
# cis.choropleth
# ------------------------------------------------------
# Description:
#   Make a choropleth map.
#
# Usage:
#   cis.colours(x, zcol, col1="orange", col2="red", formula="sturges", main="", cex=0.8)
#
# Arguments:
#   x       : SpatialPolygonsDataFrame
#   zcol    : A column used for making color ramp.
#   col1    : The name of color for lower bound.
#   col2    : The name of color for upper bound.
#   formula : Name of formula to make breakpoints.
#   main    : The title of this choropleth map.
#   cex     : Font size for the legend.
# ======================================================
cis.choropleth <- function(x, zcol, col1="orange", col2="red", formula="sturges", main="", cex=0.8, unit="", lty=1){
  # Read a required libraries.
  require(stats)
  require(grDevices)
  require(maptools)
  require(RColorBrewer)

  data <- x@data[which(colnames(x@data)==zcol)][,1]
  breaks <- cis.breaks(data, formula=formula)

  n <- breaks$class
  b <- breaks$breaks
  c <- cis.colours(col1=col1, col2=col2, class=n)
  l <- formatC(b, format="d")
  l.t <- "Legend"
  if(unit != ""){l.t <- paste(l.t,unit,sep=":")}

  plot(x,col=c[findInterval(data, b, all.inside=TRUE)],asp=1, lty=lty)
  grid()
  title(main=main)
  legend("topleft", legend=l, fill=c, cex=cex, bty="n", title=l.t)
}

# ======================================================
# cis.colours
# ------------------------------------------------------
# Description:
#   Return a list of interpolated colours with two colors
#   and with number of breakspoints.
#
# Usage:
#   cis.colours(col1="orange", col2="red", class=3)
#
# Arguments:
#   col1  : The name of color for lower bound.
#   col2  : The name of color for upper bound.
#   class : Number of breaks.
# 
# Value:
#   colours : A character with elements of 7 characters,
#             "#" followed by the red, blue, green. See 
#             'rgb' for more details.
# ======================================================
cis.colours <- function(col1="orange", col2="red", class=3){
  # Read a required library.
  require(grDevices)

  # r ramp from two colors.
  cols <- rgb(colorRamp(c(col1,col2))((0:class)/class),max=255)

  # Return a vector of colors.
  return(cols)
}

# ======================================================
# cis.breaks
# ------------------------------------------------------
# Description:
#   Get a vector of breaks with specifed formula.
#
# Usage:
#   cis.breaks(x, formula="sturges")
#
# Arguments:
#   x      : A data vector
#   formula: Name of formula to make breakpoints.
#
# Details:
#   .. $ formula: The name of used formula to make breaks.
#   .. $ class  : The suggested number of classes.
#   .. $ breaks : A vector of breakpoints.
# ======================================================
cis.breaks <- function(x, formula="sturges"){
  # Read a required library.
  require(stats)

  # Define a list to return.
  res <- list(formula=formula, class=0, breaks=0)

  # Get a name of formula.
  res$formula <- formula
  
  # Switch formula for making breaks.
  res$class <- switch(formula,
      sturges = nclass.Sturges(x),
      scott   = nclass.scott(x),
      FD      = nclass.FD(x)
  )

  # Get a vector of breaks with specifed formula.
  res$breaks <- quantile(x, probs=seq(0,1,1/(res$class)))

  # Return the result.
  return(res)
}