Nothing
R/project_midpoint.R
In iemisc: Irucka Embry's Miscellaneous Functions
#' Calculate the midpoint between two coordinates (KY and TN)
#'
#' Takes Kentucky or Tennessee-based Northing and Easting engineering survey
#' measurements [based in the State Plane Coordinate System (SPCS)] in meters,
#' international foot, or US survey foot and converts those values into
#' geodetic coordinates of the World Geodetic System (WGS) (19)84 (EPSG:4326).
#' [MapTiler Reference] Each latitude {Y} and longitude {X} point is verified to be
#' located within Kentucky or Tennessee.
#'
#'
#'
#' @param Northing_begin numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Northing_end numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Easting_begin numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Easting_end numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param units character vector that contains the system of units (options are
#' \code{survey_ft} (United States Customary System) [US survey foot],
#' \code{foot}, or \code{meters} (International System of Units) [meters]
#' {only 1 set of units at a time}
#' @param location character vector that contains the location name ('KY' for
#' Kentucky or 'TN' for Tennessee) {only 1 location at a time}
#' @param output character vector that contains simple for the default result
#' using a simple \code{\link[data.table]{data.table}} or advanced for the result as a
#' complex \code{\link[data.table]{data.table}}
#'
#'
#' @return the projected associated latitude {Y} and longitude {X} mid point
#' coordinates in Decimal Degrees as a \code{\link[data.table]{data.table}} or as an enhanced
#' \code{\link[data.table]{data.table}} with the Northing and Easting coordinates in US
#' survey foot, international foot, and meters in addition to the {Y} and {X}
#' coordinates for the begin, middle, and end points
#'
#'
#'
#' @source
#' \enumerate{
#' \item Win-Vector Blog. John Mount, June 11, 2018, "R Tip: use isTRUE()", \url{https://win-vector.com/2018/06/11/r-tip-use-istrue/}.
#' \item Latitude Longitude Coordinates to State Code in R - Stack Overflow answered by Josh O'Brien on Jan 6 2012 and edited by Josh O'Brien on Jun 18, 2020. See \url{https://stackoverflow.com/questions/8751497/latitude-longitude-coordinates-to-state-code-in-r}.
#' \item r - Convert column classes in data.table - Stack Overflow answered by Matt Dowle on Dec 27 2013. See \url{https://stackoverflow.com/questions/7813578/convert-column-classes-in-data-table}.
#' \item Excel vlook up function in R for data frame - Stack Overflow answered by Tyler Rinker on Apr 8 2013 and edited by Tyler Rinker on Feb 26 2014. See \url{https://stackoverflow.com/questions/15882743/excel-vlook-up-function-in-r-for-data-frame}.
#' \item r - How to not run an example using roxygen2? - Stack Overflow answered and edited by samkart on Jul 9 2017. (Also see the additional comments in response to the answer.) See \url{https://stackoverflow.com/questions/12038160/how-to-not-run-an-example-using-roxygen2}.
#' \item devtools - Issues in R package after CRAN asked to replace dontrun by donttest - Stack Overflow answered by Hong Ooi on Sep 1 2020. (Also see the additional comments in response to the answer.) See \url{https://stackoverflow.com/questions/63693563/issues-in-r-package-after-cran-asked-to-replace-dontrun-by-donttest}.
#' }
#'
#'
#'
#' @references
#' \enumerate{
#' \item udunits.dat, v 1.18 2006/09/20 18:59:18 steve Exp, \url{https://web.archive.org/web/20230202155021/https://www.unidata.ucar.edu/software/udunits/udunits-1/udunits.txt}. Retrieved thanks to the Internet Archive: Wayback Machine
#' \item Spatial Reference, Aug. 13, 2004, "EPSG:3088: NAD83 / Kentucky Single Zone", \url{https://spatialreference.org/ref/epsg/3088/}.
#' \item Spatial Reference, March 7, 2000, "EPSG:32136 NAD83 / Tennessee", \url{https://spatialreference.org/ref/epsg/32136/}.
#' \item MapTiler Team, "EPSG:4326: WGS 84 -- WGS84 - World Geodetic System 1984, used in GPS, \url{https://epsg.io/4326}.
#' \item Tennessee Department of Transportation Design Division, Tennessee Department of Transportation Tennessee Geodetic Reference Network (TGRN) Reference Manual Second Edition Issued, page ix, \url{https://www.tn.gov/content/dam/tn/tdot/documents/TgrnComposite.pdf}.
#' \item Earth Point, "State Plane Coordinate System - Convert, View on Google Earth", \url{https://www.earthpoint.us/StatePlane.aspx}.
#' \item National Geodetic Survey datasheet95, version 8.12.5.3, online retrieval date July 25, 2019, Mid Valley Oil Rad Relay Twr designation, HA1363 PID, Grayson County Kentucky, Clarkson (1967) USGS Quad, \url{https://www.ngs.noaa.gov/cgi-bin/ds_mark.prl?PidBox=HA1363}.
#' \item National Geodetic Survey datasheet95, version 8.12.5.3, online retrieval date July 25, 2019, 2006 42 07 designation, DL4005 PID, Fayette County Kentucky, Lexington West (1993) USGS Quad, \url{https://www.ngs.noaa.gov/cgi-bin/ds_mark.prl?PidBox=DL4005}.
#' }
#'
#'
#' @note
#' Please Note: If you have Kentucky North/South Zone survey measurements, then
#' please use the Kentucky Geological Survey, University of Kentucky - Kentucky
#' Single Coordinate Conversion Tool
#' (http://kgs.uky.edu/kgsweb/CoordConversionTool.asp) instead. That tool will
#' give you the geographic coordinates too. This R function, \code{project_midpoint}
#' will only be valid for NAD83 / Kentucky Single Zone.
#'
#' Useful Tennessee reference Web site
#' Tennessee Department of Transportation Roadway Design Survey Standards
#' \url{https://www.tn.gov/tdot/roadway-design/survey-standards.html}
#'
#' Useful Kentucky reference Web site
#' Kentucky Transportation Cabinet Survey Coordination
#' \url{https://transportation.ky.gov/Highway-Design/Pages/Survey-Coordination.aspx}
#'
#'
#'
#'
#'
#'
#'
#' @author Irucka Embry
#'
#'
#'
#' @encoding UTF-8
#'
#'
#'
#'
#'
#'
#'
#' @examples
#'
#' # Example 1
#'
#' library(iemisc)
#'
#' Northing_begin <- 283715.8495
#' Easting_begin <- 1292428.3999
#'
#' Northing_end <- 303340.6977
#' Easting_end <- 1295973.7743
#'
#' project_midpoint(Northing_begin, Easting_begin, Northing_end, Easting_end,
#' units = "survey_ft", location = "TN", output = "simple")
#'
#'
#'
#'
#'
#'
#' \donttest{
#' # See Source 5 and Source 6
#'
#' # Please see the error messages
#'
#' library(iemisc)
#'
#' # Tennessee (TN) Northing and Easting in meters
#'
#' Northing2 <- c(232489.480, 234732.431)
#'
#' Easting2 <- c(942754.124, 903795.239)
#'
#' dt4 <- try(project_midpoint(Northing2, Easting2, units = "survey_ft",
#' location = "TN", output = "simple"))
#' }
#'
#'
#'
#'
#'
#' @importFrom data.table data.table setnames copy set setattr setDF
#' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
#' @importFrom sf st_as_sf st_transform st_coordinates
#' @importFrom units set_units make_units
#' @importFrom checkmate qtest
#' @importFrom assertthat assert_that
#' @importFrom geosphere midPoint
#'
#' @export
project_midpoint <- function (Northing_begin, Easting_begin, Northing_end, Easting_end, units = c("survey_ft", "foot", "meters"), location = c("KY", "TN"), output = c("simple", "advanced")) {
m <- NULL
# due to NSE notes in R CMD check
units <- units
location <- location
ifelse(stri_detect_fixed(Northing_begin, ",") == TRUE, Northing_begin <- stri_replace_all_fixed(Northing_begin, ",", ""), Northing_begin <- Northing_begin)
ifelse(stri_detect_fixed(Easting_begin, ",") == TRUE, Easting_begin <- stri_replace_all_fixed(Easting_begin, ",", ""), Easting_begin <- Easting_begin)
ifelse(stri_detect_fixed(Northing_end, ",") == TRUE, Northing_end <- stri_replace_all_fixed(Northing_end, ",", ""), Northing_end <- Northing_end)
ifelse(stri_detect_fixed(Easting_end, ",") == TRUE, Easting_end <- stri_replace_all_fixed(Easting_end, ",", ""), Easting_end <- Easting_end)
# Check for Northing_begin, Easting_begin, Northing_end, Easting_end, units, and location
assert_that(!any(qtest(as.numeric(Northing_begin), "N==1[0,)") == FALSE), msg = "Northing_begin is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Easting_begin), "N==1[0,)") == FALSE), msg = "Easting_begin is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Northing_end), "N==1[0,)") == FALSE), msg = "Northing_end is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Easting_end), "N==1[0,)") == FALSE), msg = "Easting_end is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(qtest(location, "S==1"), msg = "There is not a location type or more than 1 location type. Please specify either 'KY' or 'TN'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(qtest(units, "S==1"), msg = "units should only be a single character vector. Please specify either 'survey_ft', 'foot', or 'meters'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(qtest(output, "S==1"), msg = "output should only be a single character vector. Please specify either 'simple' or 'advanced'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(isTRUE(any(c("KY", "TN") %in% location)), msg = "Incorrect location selection. The only possible locations are 'KY' and 'TN'. Please try again.")
# only process with a specified location and provide a stop warning if not
# Source 1
assert_that(isTRUE(any(c("survey_ft", "foot", "meters") %in% units)), msg = "Incorrect unit selection. The only possible units are 'survey_ft', 'foot', and 'meters'. Please try again.")
# only process with a specified unit and provide a stop warning if not
# Source 1
assert_that(isTRUE(any(c("simple", "advanced") %in% output)), msg = "Incorrect output selection. The only possible outputs are 'simple' and 'advanced'. Please try again.")
# only process with a specified output and provide a stop warning if not
# Source 1
Northing_begin <- as.numeric(stri_replace_all_fixed(Northing_begin, ",", ""))
Easting_begin <- as.numeric(stri_replace_all_fixed(Easting_begin, ",", ""))
if (units == "survey_ft") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
change_class <- names(distance_begin)
for (col in change_class) set(distance_begin, j = col, value = set_units(distance_begin[[col]], "US_survey_foot"))
# Source 3
units(distance_begin$Easting_begin) <- make_units(m)
units(distance_begin$Northing_begin) <- make_units(m)
for (col in change_class) set(distance_begin, j = col, value = as.numeric(distance_begin[[col]]))
# Source 3
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
} else if (units == "foot") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
change_class <- names(distance_begin)
for (col in change_class) set(distance_begin, j = col, value = set_units(distance_begin[[col]], "ft"))
# Source 3
units(distance_begin$Easting_begin) <- make_units(m)
units(distance_begin$Northing_begin) <- make_units(m)
for (col in change_class) set(distance_begin, j = col, value = as.numeric(distance_begin[[col]]))
# Source 3
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
} else if (units == "meters") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
}
setnames(data_begin, c("X", "Y"))
data_out_begin <- copy(data_begin)
Northing_end <- as.numeric(stri_replace_all_fixed(Northing_end, ",", ""))
Easting_end <- as.numeric(stri_replace_all_fixed(Easting_end, ",", ""))
if (units == "survey_ft") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
change_class <- names(distance_end)
for (col in change_class) set(distance_end, j = col, value = set_units(distance_end[[col]], "US_survey_foot"))
# Source 3
units(distance_end$Easting_end) <- make_units(m)
units(distance_end$Northing_end) <- make_units(m)
for (col in change_class) set(distance_end, j = col, value = as.numeric(distance_end[[col]]))
# Source 3
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
} else if (units == "foot") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
change_class <- names(distance_end)
for (col in change_class) set(distance_end, j = col, value = set_units(distance_end[[col]], "ft"))
# Source 3
units(distance_end$Easting_end) <- make_units(m)
units(distance_end$Northing_end) <- make_units(m)
for (col in change_class) set(distance_end, j = col, value = as.numeric(distance_end[[col]]))
# Source 3
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
} else if (units == "meters") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
}
setnames(data_end, c("X", "Y"))
data_out_end <- copy(data_end)
# check location
if (location == "KY") {
# Source 2 begins
# using sf instead of sp now
data_begin_sf <- st_as_sf(data_begin, coords = 1:2, crs = "+init=epsg:3088")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Kentucky
# Source 2 ends
data_projected_begin <- st_transform(data_begin_sf, "+init=epsg:4326")
# transform the coordinates
data_check_begin <- as.data.table(st_coordinates(data_projected_begin))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_begin[, Y], data_check_begin[, X]) == "Kentucky"), msg = "Latitude and Longitude coordinate pair is not within Kentucky. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
# Source 2 begins
# using sf instead of sp now
data_end_sf <- st_as_sf(data_end, coords = 1:2, crs = "+init=epsg:3088")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Kentucky
# Source 2 ends
data_projected_end <- st_transform(data_end_sf, "+init=epsg:4326")
# transform the coordinates
data_check_end <- as.data.table(st_coordinates(data_projected_end))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_end[, Y], data_check_end[, X]) == "Kentucky"), msg = "Latitude and Longitude coordinate pair is not within Kentucky. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
} else if (location == "TN") {
# Source 2 begins
# using sf instead of sp now
data_begin_sf <- st_as_sf(data_begin, coords = 1:2, crs = "+init=epsg:32136")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Tennessee
# Source 2 ends
data_projected_begin <- st_transform(data_begin_sf, "+init=epsg:4326")
# transform the coordinates
data_check_begin <- as.data.table(st_coordinates(data_projected_begin))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_begin[, Y], data_check_begin[, X]) == "Tennessee"), msg = "Latitude and Longitude coordinate pair is not within Tennessee. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
# Source 2 begins
# using sf instead of sp now
data_end_sf <- st_as_sf(data_end, coords = 1:2, crs = "+init=epsg:32136")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Tennessee
# Source 2 ends
data_projected_end <- st_transform(data_end_sf, "+init=epsg:4326")
# transform the coordinates
data_check_end <- as.data.table(st_coordinates(data_projected_end))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_end[, Y], data_check_end[, X]) == "Tennessee"), msg = "Latitude and Longitude coordinate pair is not within Tennessee. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
}
# populate the table fields
look_fips <- data.table(location = c("KY", "TN"), zone = c("Kentucky (Single Zone) 1600", "Tennessee 4100"))
z <- lookupQT(location, setDF(look_fips))
# Source 4
# for conversions
# meters
nm_begin <- set_units(data_out_begin$Y, "m")
em_begin <- set_units(data_out_begin$X, "m")
# US survey foof
nu_begin <- nm_begin
nu_begin <- set_units(nu_begin, "US_survey_foot")
eu_begin <- em_begin
eu_begin <- set_units(eu_begin, "US_survey_foot")
# meters
nm_end <- set_units(data_out_end$Y, "m")
em_end <- set_units(data_out_end$X, "m")
# US survey foot
nu_end <- nm_end
nu_end <- set_units(nu_end, "US_survey_foot")
eu_end <- em_end
eu_end <- set_units(eu_end, "US_survey_foot")
# foot
nf_begin <- nm_begin
nf_begin <- set_units(nf_begin, "foot")
ef_begin <- em_begin
ef_begin <- set_units(ef_begin, "foot")
nf_end <- nm_end
nf_end <- set_units(nf_end, "foot")
ef_end <- em_end
ef_end <- set_units(ef_end, "foot")
# for display
dn_begin <- sprintf("%.4f", data_check_begin$Y)
dw_begin <- sprintf("%.4f", data_check_begin$X)
dn_end <- sprintf("%.4f", data_check_end$Y)
dw_end <- sprintf("%.4f", data_check_end$X)
nm_begin <- sprintf("%.4f", nm_begin)
em_begin <- sprintf("%.4f", em_begin)
nu_begin <- sprintf("%.4f", nu_begin)
eu_begin <- sprintf("%.4f", eu_begin)
nm_end <- sprintf("%.4f", nm_end)
em_end <- sprintf("%.4f", em_end)
nu_end <- sprintf("%.4f", nu_end)
eu_end <- sprintf("%.4f", eu_end)
nf_begin <- sprintf("%.4f", nf_begin)
ef_begin <- sprintf("%.4f", ef_begin)
nf_end <- sprintf("%.4f", nf_end)
ef_end <- sprintf("%.4f", ef_end)
# return the midpoint coordinates
mp <- midPoint(data_check_begin, data_check_end)
mp <- as.data.table(mp)
setcolorder(mp, c(2, 1))
setnames(mp, c("Latitude", "Longitude"))
change_class_mp <- c("Latitude", "Longitude")
for (col in change_class_mp) set(mp, j = col, value = sprintf("%.4f", mp[[col]]))
# Source 3
mp_out <- copy(mp)
col.names <- c("Latitude", "Longitude")
colnames(mp_out) <- col.names
if(output == "simple") {
# code block below modified from data.table function
setattr(mp_out, "col.names", setnames(mp_out, col.names))
setattr(mp_out, "class", c("data.table", "data.frame"))
mp_out
} else if (output == "advanced") {
dn_mp <- mp$Latitude
dw_mp <- mp$Longitude
# table inspired by Earth Point Reference
# without the UTM information
mp_out <- data.table(names = c("Begin Project (X = East, Y = North) [US survey foot]", "End Project (X = East, Y = North) [US survey foot]", "Begin Project (X = East, Y = North) [international foot]", "End Project (X = East, Y = North) [international foot]", "Begin Project (X = East, Y = North) [meters]", "End Project (X = East, Y = North) [meters]", "Begin Project Degrees (Latitude, Longitude)", "Midpoint Project Degrees (Latitude, Longitude)", "End Project Degrees (Latitude, Longitude)"), numbers = c(paste0(z, " ", eu_begin,", ", nu_begin), paste0(z, " ", eu_end,", ", nu_end), paste0(z, " ", ef_begin,", ", nf_begin), paste0(z, " ", ef_end,", ", nf_end), paste0(z, " ", em_begin,", ", nm_begin), paste0(z, " ", em_end,", ", nm_end), paste0(dn_begin, ", ", dw_begin), paste0(dn_mp, ", ", dw_mp), paste0(dn_end, ", ", dw_end)))
setnames(mp_out, c("Parameters", "Value"))
col.names <- c("Parameters", "Value")
colnames(mp_out) <- col.names
# code block below modified from data.table function
setattr(mp_out, "col.names", setnames(mp_out, col.names))
setattr(mp_out, "class", c("data.table", "data.frame"))
mp_out
}
}
Try the iemisc package in your browser
Any scripts or data that you put into this service are public.
iemisc documentation built on Sept. 25, 2023, 5:09 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' Calculate the midpoint between two coordinates (KY and TN)
#'
#' Takes Kentucky or Tennessee-based Northing and Easting engineering survey
#' measurements [based in the State Plane Coordinate System (SPCS)] in meters,
#' international foot, or US survey foot and converts those values into
#' geodetic coordinates of the World Geodetic System (WGS) (19)84 (EPSG:4326).
#' [MapTiler Reference] Each latitude {Y} and longitude {X} point is verified to be
#' located within Kentucky or Tennessee.
#'
#'
#'
#' @param Northing_begin numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Northing_end numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Easting_begin numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param Easting_end numeric vector (or character vector with numbers, commas,
#' and decimal points) that contains the Northing engineering survey
#' measurement in meters, international foot, or US survey foot
#' @param units character vector that contains the system of units (options are
#' \code{survey_ft} (United States Customary System) [US survey foot],
#' \code{foot}, or \code{meters} (International System of Units) [meters]
#' {only 1 set of units at a time}
#' @param location character vector that contains the location name ('KY' for
#' Kentucky or 'TN' for Tennessee) {only 1 location at a time}
#' @param output character vector that contains simple for the default result
#' using a simple \code{\link[data.table]{data.table}} or advanced for the result as a
#' complex \code{\link[data.table]{data.table}}
#'
#'
#' @return the projected associated latitude {Y} and longitude {X} mid point
#' coordinates in Decimal Degrees as a \code{\link[data.table]{data.table}} or as an enhanced
#' \code{\link[data.table]{data.table}} with the Northing and Easting coordinates in US
#' survey foot, international foot, and meters in addition to the {Y} and {X}
#' coordinates for the begin, middle, and end points
#'
#'
#'
#' @source
#' \enumerate{
#' \item Win-Vector Blog. John Mount, June 11, 2018, "R Tip: use isTRUE()", \url{https://win-vector.com/2018/06/11/r-tip-use-istrue/}.
#' \item Latitude Longitude Coordinates to State Code in R - Stack Overflow answered by Josh O'Brien on Jan 6 2012 and edited by Josh O'Brien on Jun 18, 2020. See \url{https://stackoverflow.com/questions/8751497/latitude-longitude-coordinates-to-state-code-in-r}.
#' \item r - Convert column classes in data.table - Stack Overflow answered by Matt Dowle on Dec 27 2013. See \url{https://stackoverflow.com/questions/7813578/convert-column-classes-in-data-table}.
#' \item Excel vlook up function in R for data frame - Stack Overflow answered by Tyler Rinker on Apr 8 2013 and edited by Tyler Rinker on Feb 26 2014. See \url{https://stackoverflow.com/questions/15882743/excel-vlook-up-function-in-r-for-data-frame}.
#' \item r - How to not run an example using roxygen2? - Stack Overflow answered and edited by samkart on Jul 9 2017. (Also see the additional comments in response to the answer.) See \url{https://stackoverflow.com/questions/12038160/how-to-not-run-an-example-using-roxygen2}.
#' \item devtools - Issues in R package after CRAN asked to replace dontrun by donttest - Stack Overflow answered by Hong Ooi on Sep 1 2020. (Also see the additional comments in response to the answer.) See \url{https://stackoverflow.com/questions/63693563/issues-in-r-package-after-cran-asked-to-replace-dontrun-by-donttest}.
#' }
#'
#'
#'
#' @references
#' \enumerate{
#' \item udunits.dat, v 1.18 2006/09/20 18:59:18 steve Exp, \url{https://web.archive.org/web/20230202155021/https://www.unidata.ucar.edu/software/udunits/udunits-1/udunits.txt}. Retrieved thanks to the Internet Archive: Wayback Machine
#' \item Spatial Reference, Aug. 13, 2004, "EPSG:3088: NAD83 / Kentucky Single Zone", \url{https://spatialreference.org/ref/epsg/3088/}.
#' \item Spatial Reference, March 7, 2000, "EPSG:32136 NAD83 / Tennessee", \url{https://spatialreference.org/ref/epsg/32136/}.
#' \item MapTiler Team, "EPSG:4326: WGS 84 -- WGS84 - World Geodetic System 1984, used in GPS, \url{https://epsg.io/4326}.
#' \item Tennessee Department of Transportation Design Division, Tennessee Department of Transportation Tennessee Geodetic Reference Network (TGRN) Reference Manual Second Edition Issued, page ix, \url{https://www.tn.gov/content/dam/tn/tdot/documents/TgrnComposite.pdf}.
#' \item Earth Point, "State Plane Coordinate System - Convert, View on Google Earth", \url{https://www.earthpoint.us/StatePlane.aspx}.
#' \item National Geodetic Survey datasheet95, version 8.12.5.3, online retrieval date July 25, 2019, Mid Valley Oil Rad Relay Twr designation, HA1363 PID, Grayson County Kentucky, Clarkson (1967) USGS Quad, \url{https://www.ngs.noaa.gov/cgi-bin/ds_mark.prl?PidBox=HA1363}.
#' \item National Geodetic Survey datasheet95, version 8.12.5.3, online retrieval date July 25, 2019, 2006 42 07 designation, DL4005 PID, Fayette County Kentucky, Lexington West (1993) USGS Quad, \url{https://www.ngs.noaa.gov/cgi-bin/ds_mark.prl?PidBox=DL4005}.
#' }
#'
#'
#' @note
#' Please Note: If you have Kentucky North/South Zone survey measurements, then
#' please use the Kentucky Geological Survey, University of Kentucky - Kentucky
#' Single Coordinate Conversion Tool
#' (http://kgs.uky.edu/kgsweb/CoordConversionTool.asp) instead. That tool will
#' give you the geographic coordinates too. This R function, \code{project_midpoint}
#' will only be valid for NAD83 / Kentucky Single Zone.
#'
#' Useful Tennessee reference Web site
#' Tennessee Department of Transportation Roadway Design Survey Standards
#' \url{https://www.tn.gov/tdot/roadway-design/survey-standards.html}
#'
#' Useful Kentucky reference Web site
#' Kentucky Transportation Cabinet Survey Coordination
#' \url{https://transportation.ky.gov/Highway-Design/Pages/Survey-Coordination.aspx}
#'
#'
#'
#'
#'
#'
#'
#' @author Irucka Embry
#'
#'
#'
#' @encoding UTF-8
#'
#'
#'
#'
#'
#'
#'
#' @examples
#'
#' # Example 1
#'
#' library(iemisc)
#'
#' Northing_begin <- 283715.8495
#' Easting_begin <- 1292428.3999
#'
#' Northing_end <- 303340.6977
#' Easting_end <- 1295973.7743
#'
#' project_midpoint(Northing_begin, Easting_begin, Northing_end, Easting_end,
#' units = "survey_ft", location = "TN", output = "simple")
#'
#'
#'
#'
#'
#'
#' \donttest{
#' # See Source 5 and Source 6
#'
#' # Please see the error messages
#'
#' library(iemisc)
#'
#' # Tennessee (TN) Northing and Easting in meters
#'
#' Northing2 <- c(232489.480, 234732.431)
#'
#' Easting2 <- c(942754.124, 903795.239)
#'
#' dt4 <- try(project_midpoint(Northing2, Easting2, units = "survey_ft",
#' location = "TN", output = "simple"))
#' }
#'
#'
#'
#'
#'
#' @importFrom data.table data.table setnames copy set setattr setDF
#' @importFrom stringi stri_detect_fixed stri_replace_all_fixed
#' @importFrom sf st_as_sf st_transform st_coordinates
#' @importFrom units set_units make_units
#' @importFrom checkmate qtest
#' @importFrom assertthat assert_that
#' @importFrom geosphere midPoint
#'
#' @export
project_midpoint <- function (Northing_begin, Easting_begin, Northing_end, Easting_end, units = c("survey_ft", "foot", "meters"), location = c("KY", "TN"), output = c("simple", "advanced")) {
m <- NULL
# due to NSE notes in R CMD check
units <- units
location <- location
ifelse(stri_detect_fixed(Northing_begin, ",") == TRUE, Northing_begin <- stri_replace_all_fixed(Northing_begin, ",", ""), Northing_begin <- Northing_begin)
ifelse(stri_detect_fixed(Easting_begin, ",") == TRUE, Easting_begin <- stri_replace_all_fixed(Easting_begin, ",", ""), Easting_begin <- Easting_begin)
ifelse(stri_detect_fixed(Northing_end, ",") == TRUE, Northing_end <- stri_replace_all_fixed(Northing_end, ",", ""), Northing_end <- Northing_end)
ifelse(stri_detect_fixed(Easting_end, ",") == TRUE, Easting_end <- stri_replace_all_fixed(Easting_end, ",", ""), Easting_end <- Easting_end)
# Check for Northing_begin, Easting_begin, Northing_end, Easting_end, units, and location
assert_that(!any(qtest(as.numeric(Northing_begin), "N==1[0,)") == FALSE), msg = "Northing_begin is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Easting_begin), "N==1[0,)") == FALSE), msg = "Easting_begin is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Northing_end), "N==1[0,)") == FALSE), msg = "Northing_end is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(!any(qtest(as.numeric(Easting_end), "N==1[0,)") == FALSE), msg = "Easting_end is NA, NaN, Inf, -Inf, a string, empty Or contains more than 1 value. Please try again.")
# only process with finite values and provide a stop warning if not
assert_that(qtest(location, "S==1"), msg = "There is not a location type or more than 1 location type. Please specify either 'KY' or 'TN'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(qtest(units, "S==1"), msg = "units should only be a single character vector. Please specify either 'survey_ft', 'foot', or 'meters'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(qtest(output, "S==1"), msg = "output should only be a single character vector. Please specify either 'simple' or 'advanced'. Please try again.")
# only process with a single string value and provide a stop warning if not
assert_that(isTRUE(any(c("KY", "TN") %in% location)), msg = "Incorrect location selection. The only possible locations are 'KY' and 'TN'. Please try again.")
# only process with a specified location and provide a stop warning if not
# Source 1
assert_that(isTRUE(any(c("survey_ft", "foot", "meters") %in% units)), msg = "Incorrect unit selection. The only possible units are 'survey_ft', 'foot', and 'meters'. Please try again.")
# only process with a specified unit and provide a stop warning if not
# Source 1
assert_that(isTRUE(any(c("simple", "advanced") %in% output)), msg = "Incorrect output selection. The only possible outputs are 'simple' and 'advanced'. Please try again.")
# only process with a specified output and provide a stop warning if not
# Source 1
Northing_begin <- as.numeric(stri_replace_all_fixed(Northing_begin, ",", ""))
Easting_begin <- as.numeric(stri_replace_all_fixed(Easting_begin, ",", ""))
if (units == "survey_ft") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
change_class <- names(distance_begin)
for (col in change_class) set(distance_begin, j = col, value = set_units(distance_begin[[col]], "US_survey_foot"))
# Source 3
units(distance_begin$Easting_begin) <- make_units(m)
units(distance_begin$Northing_begin) <- make_units(m)
for (col in change_class) set(distance_begin, j = col, value = as.numeric(distance_begin[[col]]))
# Source 3
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
} else if (units == "foot") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
change_class <- names(distance_begin)
for (col in change_class) set(distance_begin, j = col, value = set_units(distance_begin[[col]], "ft"))
# Source 3
units(distance_begin$Easting_begin) <- make_units(m)
units(distance_begin$Northing_begin) <- make_units(m)
for (col in change_class) set(distance_begin, j = col, value = as.numeric(distance_begin[[col]]))
# Source 3
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
} else if (units == "meters") {
distance_begin <- data.table(Easting_begin = Easting_begin, Northing_begin = Northing_begin)
data_begin <- data.table(X = distance_begin[, Easting_begin], Y = distance_begin[, Northing_begin])
# Easting_begin, Northing_begin
}
setnames(data_begin, c("X", "Y"))
data_out_begin <- copy(data_begin)
Northing_end <- as.numeric(stri_replace_all_fixed(Northing_end, ",", ""))
Easting_end <- as.numeric(stri_replace_all_fixed(Easting_end, ",", ""))
if (units == "survey_ft") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
change_class <- names(distance_end)
for (col in change_class) set(distance_end, j = col, value = set_units(distance_end[[col]], "US_survey_foot"))
# Source 3
units(distance_end$Easting_end) <- make_units(m)
units(distance_end$Northing_end) <- make_units(m)
for (col in change_class) set(distance_end, j = col, value = as.numeric(distance_end[[col]]))
# Source 3
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
} else if (units == "foot") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
change_class <- names(distance_end)
for (col in change_class) set(distance_end, j = col, value = set_units(distance_end[[col]], "ft"))
# Source 3
units(distance_end$Easting_end) <- make_units(m)
units(distance_end$Northing_end) <- make_units(m)
for (col in change_class) set(distance_end, j = col, value = as.numeric(distance_end[[col]]))
# Source 3
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
} else if (units == "meters") {
distance_end <- data.table(Easting_end = Easting_end, Northing_end = Northing_end)
data_end <- data.table(X = distance_end[, Easting_end], Y = distance_end[, Northing_end])
# Easting_end, Northing_end
}
setnames(data_end, c("X", "Y"))
data_out_end <- copy(data_end)
# check location
if (location == "KY") {
# Source 2 begins
# using sf instead of sp now
data_begin_sf <- st_as_sf(data_begin, coords = 1:2, crs = "+init=epsg:3088")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Kentucky
# Source 2 ends
data_projected_begin <- st_transform(data_begin_sf, "+init=epsg:4326")
# transform the coordinates
data_check_begin <- as.data.table(st_coordinates(data_projected_begin))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_begin[, Y], data_check_begin[, X]) == "Kentucky"), msg = "Latitude and Longitude coordinate pair is not within Kentucky. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
# Source 2 begins
# using sf instead of sp now
data_end_sf <- st_as_sf(data_end, coords = 1:2, crs = "+init=epsg:3088")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Kentucky
# Source 2 ends
data_projected_end <- st_transform(data_end_sf, "+init=epsg:4326")
# transform the coordinates
data_check_end <- as.data.table(st_coordinates(data_projected_end))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_end[, Y], data_check_end[, X]) == "Kentucky"), msg = "Latitude and Longitude coordinate pair is not within Kentucky. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
} else if (location == "TN") {
# Source 2 begins
# using sf instead of sp now
data_begin_sf <- st_as_sf(data_begin, coords = 1:2, crs = "+init=epsg:32136")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Tennessee
# Source 2 ends
data_projected_begin <- st_transform(data_begin_sf, "+init=epsg:4326")
# transform the coordinates
data_check_begin <- as.data.table(st_coordinates(data_projected_begin))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_begin[, Y], data_check_begin[, X]) == "Tennessee"), msg = "Latitude and Longitude coordinate pair is not within Tennessee. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
# Source 2 begins
# using sf instead of sp now
data_end_sf <- st_as_sf(data_end, coords = 1:2, crs = "+init=epsg:32136")
# where X and Y stand for Longitude / Latitude columns
# coordinates are in NAD83 / Tennessee
# Source 2 ends
data_projected_end <- st_transform(data_end_sf, "+init=epsg:4326")
# transform the coordinates
data_check_end <- as.data.table(st_coordinates(data_projected_end))
# retrieve the coordinates as a matrix and then convert to a data.table
assert_that(isTRUE(lat_long2state(data_check_end[, Y], data_check_end[, X]) == "Tennessee"), msg = "Latitude and Longitude coordinate pair is not within Tennessee. Please check the Easting and try again. Are the units in US survey foot or meters?")
# Source 1
}
# populate the table fields
look_fips <- data.table(location = c("KY", "TN"), zone = c("Kentucky (Single Zone) 1600", "Tennessee 4100"))
z <- lookupQT(location, setDF(look_fips))
# Source 4
# for conversions
# meters
nm_begin <- set_units(data_out_begin$Y, "m")
em_begin <- set_units(data_out_begin$X, "m")
# US survey foof
nu_begin <- nm_begin
nu_begin <- set_units(nu_begin, "US_survey_foot")
eu_begin <- em_begin
eu_begin <- set_units(eu_begin, "US_survey_foot")
# meters
nm_end <- set_units(data_out_end$Y, "m")
em_end <- set_units(data_out_end$X, "m")
# US survey foot
nu_end <- nm_end
nu_end <- set_units(nu_end, "US_survey_foot")
eu_end <- em_end
eu_end <- set_units(eu_end, "US_survey_foot")
# foot
nf_begin <- nm_begin
nf_begin <- set_units(nf_begin, "foot")
ef_begin <- em_begin
ef_begin <- set_units(ef_begin, "foot")
nf_end <- nm_end
nf_end <- set_units(nf_end, "foot")
ef_end <- em_end
ef_end <- set_units(ef_end, "foot")
# for display
dn_begin <- sprintf("%.4f", data_check_begin$Y)
dw_begin <- sprintf("%.4f", data_check_begin$X)
dn_end <- sprintf("%.4f", data_check_end$Y)
dw_end <- sprintf("%.4f", data_check_end$X)
nm_begin <- sprintf("%.4f", nm_begin)
em_begin <- sprintf("%.4f", em_begin)
nu_begin <- sprintf("%.4f", nu_begin)
eu_begin <- sprintf("%.4f", eu_begin)
nm_end <- sprintf("%.4f", nm_end)
em_end <- sprintf("%.4f", em_end)
nu_end <- sprintf("%.4f", nu_end)
eu_end <- sprintf("%.4f", eu_end)
nf_begin <- sprintf("%.4f", nf_begin)
ef_begin <- sprintf("%.4f", ef_begin)
nf_end <- sprintf("%.4f", nf_end)
ef_end <- sprintf("%.4f", ef_end)
# return the midpoint coordinates
mp <- midPoint(data_check_begin, data_check_end)
mp <- as.data.table(mp)
setcolorder(mp, c(2, 1))
setnames(mp, c("Latitude", "Longitude"))
change_class_mp <- c("Latitude", "Longitude")
for (col in change_class_mp) set(mp, j = col, value = sprintf("%.4f", mp[[col]]))
# Source 3
mp_out <- copy(mp)
col.names <- c("Latitude", "Longitude")
colnames(mp_out) <- col.names
if(output == "simple") {
# code block below modified from data.table function
setattr(mp_out, "col.names", setnames(mp_out, col.names))
setattr(mp_out, "class", c("data.table", "data.frame"))
mp_out
} else if (output == "advanced") {
dn_mp <- mp$Latitude
dw_mp <- mp$Longitude
# table inspired by Earth Point Reference
# without the UTM information
mp_out <- data.table(names = c("Begin Project (X = East, Y = North) [US survey foot]", "End Project (X = East, Y = North) [US survey foot]", "Begin Project (X = East, Y = North) [international foot]", "End Project (X = East, Y = North) [international foot]", "Begin Project (X = East, Y = North) [meters]", "End Project (X = East, Y = North) [meters]", "Begin Project Degrees (Latitude, Longitude)", "Midpoint Project Degrees (Latitude, Longitude)", "End Project Degrees (Latitude, Longitude)"), numbers = c(paste0(z, " ", eu_begin,", ", nu_begin), paste0(z, " ", eu_end,", ", nu_end), paste0(z, " ", ef_begin,", ", nf_begin), paste0(z, " ", ef_end,", ", nf_end), paste0(z, " ", em_begin,", ", nm_begin), paste0(z, " ", em_end,", ", nm_end), paste0(dn_begin, ", ", dw_begin), paste0(dn_mp, ", ", dw_mp), paste0(dn_end, ", ", dw_end)))
setnames(mp_out, c("Parameters", "Value"))
col.names <- c("Parameters", "Value")
colnames(mp_out) <- col.names
# code block below modified from data.table function
setattr(mp_out, "col.names", setnames(mp_out, col.names))
setattr(mp_out, "class", c("data.table", "data.frame"))
mp_out
}
}
Try the iemisc package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.