R/coord_utils.R

In madlogos/aseshms: Toolkit for ASES HMS Team

.atn2 <- function(y, x){
    if (x > 0) {
        return(atan(y / x))
    }else if (x < 0) {
        return(sign(y) * (pi - atan(abs(y / x))))
    }else if (y == 0){
        return(0)
    }else{
        return(sign(y) * pi / 2.0)
    }
}

atn2 <- function(y, x){
    y <- unlist(y)
    x <- unlist(x)
    return(mapply(.atn2, y, x))
}

isOutOfChina <- function(Lat, Lon){
    # to check if the plase is out of China
    if (length(Lat) > 1) 
        warning("The length of Lat is larger than 1, only the first element will be used.")
    if (length(Lon) > 1) 
        warning("The length of Lon is larger than 1, only the first element will be used.")
    OutOfChina <- FALSE
    if (Lon[[1]] < 72.004 | Lon[[1]] > 137.8347) OutOfChina <- TRUE
    if (Lat[[1]] < 0.8293 | Lat[[1]] > 55.8271) OutOfChina <- TRUE
    return(OutOfChina)
}

transformLat <- function(x, y){
    # China encrpytion of latitudes
    stopifnot(length(x) == length(y))
    ret <- -100.0 + 2.0 * x + 3.0 * y + 0.2 * y ^ 2 + 0.1 * x * y + 0.2 * sqrt(abs(x))
    ret <- ret + (20.0 * sin(6.0 * x * pi) + 20.0 * sin(2.0 * x * pi)) * 2.0 / 3.0
    ret <- ret + (20.0 * sin(y * pi) + 40.0 * sin(y / 3.0 * pi)) * 2.0 / 3.0
    ret <- ret + (160.0 * sin(y / 12.0 * pi) + 320.0 * sin(y * pi / 30.0)) * 2.0 / 3.0
    return(ret)
}

transformLon <- function(x, y){
    # China encryption of longitudes
    stopifnot(length(x) == length(y))
    ret <- 300.0 + x + 2.0 * y + 0.1 * x ^ 2 + 0.1 * x * y + 0.1 * sqrt(abs(x))
    ret <- ret + (20.0 * sin(6.0 * x * pi) + 20.0 * sin(2.0 * x * pi)) * 2.0 / 3.0
    ret <- ret + (20.0 * sin(x * pi) + 40.0 * sin(x / 3.0 * pi)) * 2.0 / 3.0
    ret <- ret + (150.0 * sin(x / 12.0 * pi) + 300.0 * sin(x / 30.0 * pi)) * 2.0 / 3.0
    return(ret)
}

formatCoordArgs <- function(out){
    # clean up the output of getCoordArgs
    if (! is.null(out)){
        names(out) <- c('lat', 'lon')
        out[is.na(out$lat) | is.na(out$lon), ] <- c(NA, NA)
        if (any(abs(out['lat']) > 90 & abs(out['lon']) > 180, na.rm=TRUE))
            stop("Lat should be within [-90, 90], Lon should be within [-180, 180].")
        return(out)
    }
}

getCoordArgs <- function(y, ...){
    ## Coarse params to a 2-col data.frame
    UseMethod(".getCoordArgs")
}

.getCoordArgs.vector <- function(y, ...){
    y <- as.numeric(y)
    if (length(y) == 1){
        ## y refers to a coordinate
        ## return one point
        x <- list(...)
        if (! length(x) == 0) {
            x <- as.numeric(x)[[1]][1]
        }else{
            x <- NA
        }
        out <- data.frame(lat=y, lon=x)
    }else if (length(y) >= 2) {
        ## y refers to one point
        ## return all possible points
        x <- list(...)
        if (length(x) >= 1){
            x <- t(sapply(x, function(l) as.numeric(l[1:2])))
            out <- rbind(y[1:2], as.data.frame(x))
            out <- as.data.frame(out, stringsAsFactors=FALSE)
        }else{
            out <- as.data.frame(t(y[1:2]))
        }
    }
    return(formatCoordArgs(out))
}

.getCoordArgs.list <- function(y, ...){
    y <- try(sapply(y, function(l) as.numeric(l[1:2])), silent=TRUE)
    if (class(y) != 'try-error')
        out <- as.data.frame(y, stringsAsFactors=FALSE)
    return(formatCoordArgs(out))
}


.getCoordArgs.matrix <- function(y, ...){
    if (ncol(y) == 1 || nrow(y) == 1){
        y <- as.vector(y)
        if (length(y) ==1) {
            out <- data.frame(lat=NA, lon=NA)
        }else{
            out <- data.frame(lat=y[1], lon=y[2])
        }
    }else{
        stopifnot(all(abs(as.vector(y)) <= 180, na.rm=TRUE))
        colcat <- rowcat <- vector(length=2)
        colcat[1] <- ifelse(any(abs(y[, 1]) > 90, na.rm=TRUE), 'lon', 'lat')
        colcat[2] <- ifelse(any(abs(y[, 2]) > 90, na.rm=TRUE), 'lon', 'lat')
        rowcat[1] <- ifelse(any(abs(y[1, ]) > 90, na.rm=TRUE), 'lon', 'lat')
        rowcat[2] <- ifelse(any(abs(y[2, ]) > 90, na.rm=TRUE), 'lon', 'lat')
        if (colcat[1] == colcat[2] && rowcat[1] == rowcat[2])
            stop("Cannot distinguish lat and lon in the matrix either col 1-2 or row 1-2.")
        
        if (colcat[1] != colcat[2]){
            out <- data.frame(as.numeric(y[, 1]), as.numeric(y[, 2]))
            names(out) <- colcat
        }else{
            out <- data.frame(as.numeric(y[1, ]), as.numeric(y[2, ]))
            names(out) <- rowcat
        }
        out <- out[, c("lat", "lon")]
    }
    return(checkCoordArgs(out))
}

.getCoordArgs.data.frame <- function(y, ...){
    ## get the first two columns
    y <- y[,1:2]
    y <- as.data.frame(sapply(y, as.character, simplify=FALSE),
                       stringsAsFactors=FALSE)
    y <- as.data.frame(sapply(y, as.numeric, simplify=FALSE))
    out <- y
    return(formatCoordArgs(out))
}

.getCoordArgs.default <- .getCoordArgs.vector

NULLtoNA <- function(x){
	# fill NULL with NA, used for geocode functions
	# author: Cai Jun
	#
    if (is.null(x)) return(NA)
    if (is.character(x) & length(x) == 0) return(NA)
    x
}