first vetsion

.gitignore

@@ -9,3 +9,4 @@
 
 # RStudio files
 .Rproj.user/
+/.project

DESCRIPTION

@@ -0,0 +1,13 @@
+Package: RbaiduLBS
+License: GPL-3
+Title: An interface to Baidu LBS API
+Type: Package
+LazyLoad: yes
+Author: Jian Li
+Maintainer: Jian Li <[email protected]>
+Description: This package provides an interface to Baidu LBS API
+Version: 0.0-3
+Date: 2015-07-22
+Depends: R (>= 2.12.0), methods, utils, tools, RCurl, rjson, png
+Imports: methods
+

NAMESPACE

@@ -0,0 +1,3 @@
+
+#exportPattern("^[^\\.]")
+exportPattern(".")

R/BaiduObject.R

@@ -0,0 +1,57 @@
+
+setRefClass("BaiduLBS", 
+		fields = list(
+				appPath = "character", 
+				appID = "character", 
+				appName = "character", 
+				appAK = "character", 
+				apiMsg = "character",
+				webCurl = "ANY"
+		),
+
+		methods = list(
+			initialize = function(appID) {
+				.self$appPath <- getOption("baidu.ak.path")
+				.self$appID <- appID
+				applist <- listKeys(appID)[[appID]]
+				.self$appName <- applist$app_name
+				.self$appAK <- applist$app_ak
+				.self$apiMsg <- "Can not access baidu API!"
+				.self$webCurl <- getCurlHandle()
+
+			},	
+			testaccess = function() {
+
+				OUT <- FALSE
+				strurl <- paste0("http://api.map.baidu.com/geocoder/v2/?address=%B0%D9%B6%C8%B4%F3%CF%C3&output=json&ak=",
+						.self$appAK)
+				resjson <- try(getURL(strurl, ssl.verifypeer = FALSE, curl = .self$webCurl, .encoding = "UTF-8"), silent = TRUE)
+				reslist <- try(.fromJSON(json = resjson), silent = TRUE)
+				if (is.list(reslist) && identical(reslist$status, 0)) OUT <- TRUE
+				return(OUT)
+			},
+			list = function() {
+				OUT <- base::list(
+						"appPath" = .self$appPath, 
+						"appID" = .self$appID, 
+						"appName" = .self$appName, 
+						"appAK" = .self$appAK
+				)
+				return(OUT)
+			}
+		)
+)
+
+
+setMethod("show", signature="BaiduLBS", 
+		function(object) {
+			print(paste("Application: ", object$appID, " (", object$appName, ")", sep = ""))
+			print(object$apiMsg)
+		}
+)
+
+
+
+
+
+

R/createBaiduLBS.R

@@ -0,0 +1,28 @@
+
+
+##' Create an authorized object
+##' 
+##' @title Create an Baidu LBS object
+##' @param app_id ID of the application.
+##' @return An reference object of \code{\link{BaiduLBS}}.
+##' @note There is only one BaiduLBS object needed.
+##' @author Jian Li <\email{rweibo@@sina.com}>
+##' @seealso \code{\link{registerKey}}
+##' @references \url{http://developer.baidu.com/map}
+##' @keywords authorization
+##' @examples \dontrun{
+##' 
+##' baidu <- createBaiduLBS("1234567")
+##' }
+createBaiduLBS <- function(app_id) {
+	oauthobj <- new("BaiduLBS", appID = app_id)
+
+	if (oauthobj$testaccess()) {
+		oauthobj$apiMsg <- "Access Baidu LBS API successfully!"
+	}
+
+	return(oauthobj)
+}
+
+
+

R/geoconv.R

@@ -0,0 +1,51 @@
+
+##' Convert other coordinates to Baidu coordinate.
+##' 
+##' @title Convert other coordinates to Baidu coordinate.
+##' @param geodf data frame to be converted.
+##' @param from From what coordinate.
+##' @param to To what coordinate.
+##' @param lonCol Column name of the longitude.
+##' @param latCol Column name of the latitude.
+##' @return a data.frame. 
+##' @author Jian Li <\email{rweibo@@sina.com}>
+##' @references \url{http://developer.baidu.com/map/index.php?title=webapi/guide/changeposition}
+
+geoconv <- function(geodf, 
+		from = c("GPS", "GPSmc", "google", "googlemc", "bd09ll", "bd09mc", "mapbar", "51map"),
+		to = c("bd09ll", "bd09mc"),
+		lonCol = "Lon", latCol = "Lat", ak = NULL) 
+{
+
+	if (is.null(ak)) ak <- getOption("baidu.ak")
+	from <- match.arg(from)
+	to <- match.arg(to)
+	from <- which(c("GPS", "GPSmc", "google", "googlemc", "bd09ll", "bd09mc", "mapbar", "51map") == from)
+	to <- which(c("bd09ll", "bd09mc") == to) + 4
+	OUT <- geodf[, c(lonCol, latCol)]
+
+	n <- ceiling(nrow(geodf) / 100)
+	for (i in 1:n) {
+		tmp.lon <- geodf[[lonCol]][(100*(i-1)+1):(min(100*i, nrow(geodf)))]
+		tmp.lat <- geodf[[latCol]][(100*(i-1)+1):(min(100*i, nrow(geodf)))]
+
+		strgeo <- paste(tmp.lon, tmp.lat, sep = ",", collapse = ";")
+		strurl <- paste0("http://api.map.baidu.com/geoconv/v1/?coords=",
+				strgeo, "&from=", from, "&to=", to, "&output=json&ak=", ak)
+
+		res.json <- getURL(strurl, ssl.verifypeer = FALSE, 
+				curl = getCurlHandle(), .encoding = "UTF-8")
+		res.list <- fromJSON(json_str = res.json)
+
+		OUT[[lonCol]][(100*(i-1)+1):(min(100*i, nrow(geodf)))] <- sapply(res.list$result, "[[", 1)
+		OUT[[latCol]][(100*(i-1)+1):(min(100*i, nrow(geodf)))] <- sapply(res.list$result, "[[", 2)
+
+	}
+
+	return(OUT)
+}
+
+
+
+
+

R/getGeocoding.R

@@ -0,0 +1,76 @@
+
+##' Get geocoding of an address or get the address of geocoding.
+##' 
+##' @title Geocoding API.
+##' @name Geocoding API
+##' @aliases getGeocoding revGeocoding
+##' @param address String of address.
+##' @param city City name.
+##' @param ak Access key of an application.
+##' @param location A numeric vecter with 2 elements indicating latitude and longitude.
+##' @param coordtype Coordinate type, one of the "bd09ll", "gcj02ll" and "wgs84ll".
+##' @param around Whether to output the POIs around.
+##' @return a data.frame. 
+##' @author Jian Li <\email{rweibo@@sina.com}>
+##' @references \url{http://developer.baidu.com/map/index.php?title=webapi/guide/webservice-geocoding}
+##' @examples \dontrun{
+##' getGeocoding("KFC")
+##' revGeocoding(c(22.3087, 114.2019))
+##' }
+
+getGeocoding <- function(address, city, ak = NULL) {
+	#address <- URLencode(address)
+	#city <- URLencode(city)
+	if (missing(city)) city <- intToUtf8(c(20840, 22269), multiple = FALSE)
+	if (is.null(ak)) ak <- getOption("baidu.ak")
+	strurl <- paste0("http://api.map.baidu.com/geocoder/v2/?address=",
+			address, "&city=", city, "&output=json&ak=", ak)
+	res.json <- getURL(strurl, ssl.verifypeer = FALSE, 
+			curl = getCurlHandle(), .encoding = "UTF-8")
+	res.list <- fromJSON(json_str = res.json)
+
+	if (res.list$status == 0 && length(res.list$result) > 0) {
+		res <- data.frame(address = address, city = city,
+				lat = res.list$result$location$lat,
+				lng = res.list$result$location$lng,
+				precise = res.list$result$precise,
+				confidence = res.list$result$confidence,
+				level = res.list$result$level,
+				stringsAsFactors = FALSE)
+	} else {
+		res <- data.frame(address = character(), city = character(),
+				lat = numeric(),
+				lng = numeric(),
+				precise = numeric(),
+				confidence = numeric(),
+				level = character(),
+				stringsAsFactors = FALSE)
+	}
+
+	return(res)
+}
+
+
+##' @name Geocoding API
+##' @aliases getGeocoding revGeocoding
+revGeocoding <- function(location, coordtype = c("bd09ll", "gcj02ll", "wgs84ll"), 
+		around = FALSE, ak = NULL) 
+{
+	location <- unlist(location)
+	location <- paste(location, collapse = ",")
+	coordtype <- match.arg(coordtype)
+	pois <- ifelse(identical(around, TRUE), 1, 0)
+	if (is.null(ak)) ak <- getOption("baidu.ak")
+
+	strurl <- paste0("http://api.map.baidu.com/geocoder/v2/?location=",
+			location, "&coordtype=", coordtype, "&pois=", pois, 
+			"&output=json&ak=", ak)
+	res.json <- getURL(strurl, ssl.verifypeer = FALSE, 
+			curl = getCurlHandle(), .encoding = "UTF-8")
+	res.list <- fromJSON(json_str = res.json)
+
+	return(res.list)
+}
+
+
+

R/getStaticImage.R

@@ -0,0 +1,45 @@
+
+##' Get static image and save it as png file.
+##' 
+##' @title Static image API.
+##' @param location A numeric vecter with 2 elements indicating latitude and longitude.
+##' @param outfile Path of the output png file.
+##' @param width Width of the image.
+##' @param height Height of the image.
+##' @param zoom Zoom size.
+##' @return The path of output file. 
+##' @author Jian Li <\email{rweibo@@sina.com}>
+##' @references \url{http://developer.baidu.com/map/index.php?title=static}
+##' @examples \dontrun{
+##' getStaticImage(c(22.3087, 114.2019))
+##' }
+
+getStaticImage <- function(location, outfile = "staticimage.png", width = 400, height = 300, zoom = 19, 
+		labels = FALSE, labelcontent = "\u6210\u529F\u7387: ", labelfontsize = 14, labelfontcol = "0xffffff",
+		labelbgcol = "0x000fff"
+) {
+
+	location <- unlist(location)
+	location <- paste(sort(location, decreasing = TRUE), collapse = ",")
+
+	if (identical(labels, TRUE)) {
+		strurl <- paste0("http://api.map.baidu.com/staticimage?center=",
+				location, "&width=", width, "&height=", height, "&zoom=", zoom,
+				"&labels=", location, "&labelStyles=", labelcontent, ",1,", 
+				labelfontsize, ",", labelfontcol, ",", labelbgcol, ",1")
+	} else {
+		strurl <- paste0("http://api.map.baidu.com/staticimage?center=",
+				location, "&width=", width, "&height=", height, "&zoom=", zoom,
+				"&markers=", location, "&markerStyles=1,A")
+	}
+
+	res.bin <- getURLContent(strurl, binary = TRUE)
+	res.png <- readPNG(res.bin)
+
+	outfile <- normalizePath(outfile, mustWork = FALSE)
+	writePNG(res.png, target = outfile)
+	return(outfile)
+
+}
+
+

R/manageKey.R

@@ -0,0 +1,94 @@
+
+
+
+##' @description Reigster, modify and delete application.
+##' 
+##' @title Reigster, modify and delete application.
+##' @name Manage keys
+##' @aliases registerKey modifyKey deleteKey listKeys
+##' @param app_id ID of an application
+##' @param app_name name of an application
+##' @param app_ak access key of an application
+##' @return a logical value 
+##' @note You should register an application on baidu firstly.
+##' @author Jian Li <\email{rweibo@@sina.com}>
+##' @references \url{http://developer.baidu.com/map}
+##' @keywords authorization
+##' @examples \dontrun{
+##' registerKey(app_id = "1234567", "test", "MCD8BKwGdgPHvAuvgvz4EQpD")
+##' listKeys("1234567")
+##' modifyKey("1234567", "t1", "t2")
+##' deleteKey("1234567")
+##' }
+registerKey <- function(app_id, app_name, app_ak) {
+	app_id <- as.character(app_id)
+	app_name <- as.character(app_name)
+	app_ak <- as.character(app_ak)
+	apppath <- getOption("baidu.ak.path")
+	if (!file.exists(apppath)) dir.create(apppath)
+	if (file.exists(file.path(apppath, app_id))) {
+		warning(paste0("The key '", app_id, "' has been registered, please use 'modifyKey' to make change."))
+		invisible(FALSE)
+	} else {
+		applist <- list(app_id = app_id, app_name = app_name, app_ak = app_ak)
+		appfile <- file(file.path(apppath, app_id) , open = "w" )
+		writeLines(toJSON(applist), appfile)
+		close(appfile)
+		invisible(TRUE)
+	}
+	if (is.null(getOption("baidu.ak"))) options(baidu.ak = app_ak)
+}
+
+##' @name Manage keys
+##' @aliases registerKey modifyKey deleteKey listKeys
+modifyKey <- function(app_id, app_name, app_ak) {
+	apppath <- getOption("baidu.ak.path")
+	if (!file.exists(apppath)) dir.create(apppath)
+	if (app_id %in% list.files(apppath)) {
+		applist <- .fromJSON(file.path(apppath, app_id))
+		applist$app_name <- app_name
+		applist$app_ak <- app_ak
+		appfile <- file(file.path(apppath, app_id) , open = "w" )
+		writeLines(toJSON(applist), appfile)
+		close(appfile)
+	} else {
+		stop(paste(app_name, "doesn't exist, please use 'registerKey' to create"))
+	}
+	return(TRUE)
+}
+
+##' @name Manage keys
+##' @aliases registerKey modifyKey deleteKey listKeys
+deleteKey <- function(app_id) {
+	apppath <- getOption("baidu.ak.path")
+	if (!file.exists(apppath)) dir.create(apppath)
+	if (file.exists(file.path(apppath, app_id))) {
+		unlink(file.path(apppath, app_id))
+	} else {
+		stop(paste(app_id, "doesn't exist"))
+	}
+	return(TRUE)
+}
+
+##' @name Manage keys
+##' @aliases registerKey modifyKey deleteKey listKeys
+listKeys <- function(app_id) {
+	apppath <- getOption("baidu.ak.path")
+	if (!file.exists(apppath)) dir.create(apppath)
+	appfiles <- list.files(apppath, full.names = FALSE)
+
+	if (missing(app_id)) {
+		app_id <- appfiles
+	}
+
+	applist <- list()
+	for (i in 1:length(app_id)) {
+		if (app_id[i] %in% appfiles) {
+			applist[[app_id[i]]] <- .fromJSON(file.path(apppath, app_id[i]))
+		}
+	}
+
+	return(applist)
+
+}
+