R/latitude_longitude_cwp_manipulation.R
In OB7-IRD/furdeb: FUnctions for R DEvelopment and Beyond!
Defines functions
latitude_longitude_cwp_manipulation
Documented in
latitude_longitude_cwp_manipulation
#' @name latitude_longitude_cwp_manipulation
#' @title Conversion function for latitude, longitude and cwp item
#' @description Conversion function for latitude, longitude and cwp item. For more information on the cwp format check the online document on https://www.fao.org/cwp-on-fishery-statistics/handbook/general-concepts/main-water-areas/en/#c737533.
#' @param manipulation_process {\link[base]{character}} expected. A string matching one of the accepted processes. Available processes are "cwp_to_latitude_longitude" or "latitude_longitude_to_cwp".
#' @param data_longitude {\link[base]{character}} expected. By default NULL. Mandatory argument for "latitude_longitude_to_cwp" process. A string vector with longitude value(s). Formats allowed is decimal degree (with point separator) or in degree minute seconde format (xxdxx'xx''). If values are duplicated, the function simplify the process automatically (no need to remove them before).
#' @param data_latitude {\link[base]{character}} expected. By default NULL. Mandatory argument for "latitude_longitude_to_cwp" process. A string vector with latitude value(s). Formats allowed is decimal degree (with point separator) or in degree minute seconde format (xxdxx'xx''). If values are duplicated, the function simplify the process automatically (no need to remove them before).
#' @param data_cwp {\link[base]{character}} expected. By default NULL. Mandatory argument for "cwp_to_latitude_longitude" process. A string vector with cwp value(s).
#' @param referential_grid_file_path {\link[base]{character}} expected. File path of the referential grid shape. File with .Rdata extension file expected.
#' @param output_degree_format {\link[base]{character}} expected. By default NULL. Mandatory for "cwp_to_latitude_longitude" process. A string matching one of the accepted output degree format. Available formats are "degree_minute_seconde" and "decimal_degree".
#' @param output_degree_parameter {\link[base]{character}} expected. By default NULL. Mandatory for "cwp_to_latitude_longitude" process. You can choose between "centroid" or "corner" for display coordinates of the square according to the centroid or the corner of it.
#' @param input_degree_format {\link[base]{character}} expected. By default NULL. Mandatory for "latitude_longitude_to_cwp" process. A string matching one of the accepted output degree format. Available formats are "degree_minute_seconde" and "decimal_degree".
#' @param epsg_code {\link[base]{integer}} expected. By default 4326. Mandatory for "latitude_longitude_to_cwp" process. An integer (on 4 digits) of one EPSG spatial reference systems related to latitude and longitude coordinates provide. Check this web site for more informations: https://www.spatialreference.org. By default 4326.
#' @return Return a tibble.
#' @importFrom dplyr last tibble inner_join rowwise mutate ungroup select rename case_when left_join
#' @importFrom sf st_coordinates st_centroid st_as_sf st_join st_intersects st_drop_geometry
#' @importFrom stringr str_extract
#' @importFrom codama r_type_checking file_path_checking
#' @export
latitude_longitude_cwp_manipulation <- function(manipulation_process,
data_longitude = NULL,
data_latitude = NULL,
data_cwp = NULL,
referential_grid_file_path,
output_degree_format = NULL,
output_degree_parameter = NULL,
input_degree_format = NULL,
epsg_code = as.integer(4326)) {
# 1 - setup ----
suppressMessages(sf::sf_use_s2(use_s2 = FALSE))
# 2 - local binding global variables ----
geometry <- NULL
X <- NULL
Y <- NULL
latitude <- NULL
longitude <- NULL
latitude_degree <- NULL
latitude_minute <- NULL
sign_latitude <- NULL
latitude_seconde <- NULL
longitude_degree <- NULL
longitude_minute <- NULL
sign_longitude <- NULL
longitude_seconde <- NULL
cwp <- NULL
latitude_degree_minute_seconde <- NULL
latitude_decimal_degree <- NULL
longitude_degree_minute_seconde <- NULL
longitude_decimal_degree <- NULL
count <- NULL
data_id <- NULL
CWP_B <- NULL
X_COORD <- NULL
Y_COORD <- NULL
CWP_CODE <- NULL
# 3 - global arguments verifications ----
# manipulation_process argument checking
if (codama::r_type_checking(r_object = manipulation_process,
type = "character",
length = 1L,
allowed_value = c("latitude_longitude_to_cwp",
"cwp_to_latitude_longitude"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = manipulation_process,
type = "character",
length = 1L,
allowed_value = c("latitude_longitude_to_cwp",
"cwp_to_latitude_longitude"),
output = "message"))
}
# referential_grid_file_path argument checking
if (codama::file_path_checking(file_path = referential_grid_file_path,
extension = c("Rdata",
"RData"),
output = "logical") != TRUE) {
return(codama::file_path_checking(file_path = referential_grid_file_path,
extension = c("Rdata",
"RData"),
output = "message"))
}
# import reference grid ----
reference_grid <- get(x = load(file = referential_grid_file_path))
if (paste(class(reference_grid),
collapse = " ") != "sf tbl_df tbl data.frame") {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid fao shapefile, R object of class sf expected.\n"))
}
if (codama::r_type_checking(r_object = names(reference_grid),
type = "character",
allowed_value = c("CWP_CODE",
"GRIDTYPE",
"QUADRANT",
"X_Y_TYPE",
"X_COORD",
"Y_COORD",
"CWP_A",
"CWP_B",
"CWP_C",
"CWP_D",
"CWP_E",
"SURFACE",
"ON_SEA",
"ON_LAND",
"ON_LAND_P",
"ON_SEA_P",
"geometry"),
output = "logical") != TRUE) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid fao shapefile, use the function \"fao_shape_manipulation\" to prepare the grid the first time.\n"))
}
cwp_resolution <- unique(x = reference_grid$GRIDTYPE)
if (length(x = cwp_resolution) != 1) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, invalid \"reference_grid\" argument, multiple cwp resolutions inside the referential.\n"))
}
if (length(x = unique(sapply(X = reference_grid$CWP_CODE,
FUN = nchar))) != 1) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, invalid reference grid, CWP of multiple length inside the referential.\n"))
}
# 4 - Process ----
if (manipulation_process == "cwp_to_latitude_longitude") {
if (codama::r_type_checking(r_object = data_cwp,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_cwp,
type = "character",
output = "message"))
} else {
cwp_length <- unique(sapply(X = data_cwp,
FUN = nchar))
data_cwp <- dplyr::tibble(cwp = data_cwp)
data_cwp_unique <- unique(x = data_cwp)
if (cwp_length != unique(sapply(X = reference_grid$CWP_CODE,
FUN = nchar))) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, dispencrecy between \"input_cwp_format\" argument and referential grid.\n"))
}
if (codama::r_type_checking(r_object = output_degree_format,
type = "character",
length = 1L,
allowed_value = c("decimal_degree",
"degree_minute_seconde"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = output_degree_format,
type = "character",
length = 1L,
allowed_value = c("decimal_degree",
"degree_minute_seconde"),
output = "message"))
}
if (codama::r_type_checking(r_object = output_degree_parameter,
type = "character",
length = 1L,
allowed_value = c("centroid",
"corner"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = output_degree_parameter,
type = "character",
length = 1L,
allowed_value = c("centroid",
"corner"),
output = "message"))
}
if (cwp_length %in% c(7)) {
data_cwp_unique_final <- dplyr::inner_join(x = data_cwp_unique,
y = reference_grid[, c("geometry",
"CWP_CODE")],
by = c("cwp" = "CWP_CODE"))
if (nrow(x = data_cwp_unique_final) != 0) {
if (output_degree_parameter == "centroid") {
data_cwp_unique_final <- suppressWarnings(data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = data.frame(sf::st_coordinates(x = sf::st_centroid(x = geometry)))$Y),
longitude = as.numeric(x = data.frame(sf::st_coordinates(x = sf::st_centroid(x = geometry)))$X)) %>%
dplyr::ungroup() %>%
dplyr::select(-geometry))
} else if (output_degree_parameter == "corner") {
data_cwp_unique_final <- suppressWarnings(data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = dplyr::distinct(data.frame(sf::st_coordinates(x = geometry)) %>%
mutate(X = round(x = abs(x = X),
digits = 2),
Y = round(x = abs(x = Y),
digits = 2)) %>%
dplyr::filter(X == min(X)) %>%
dplyr::filter(Y == min(Y))))[2],
longitude = as.numeric(x = dplyr::distinct(data.frame(sf::st_coordinates(x = geometry)) %>%
mutate(X = round(x = abs(x = X),
digits = 2),
Y = round(x = abs(x = Y),
digits = 2)) %>%
dplyr::filter(X == min(X)) %>%
dplyr::filter(Y == min(Y))))[1]) %>%
dplyr::ungroup() %>%
dplyr::select(-geometry))
}
if (output_degree_format == "decimal_degree") {
data_cwp_unique_final <- dplyr::rename(.data = data_cwp_unique_final,
latitude_decimal_degree = latitude,
longitude_decimal_degree = longitude)
} else if (output_degree_format == "degree_minute_seconde") {
data_cwp_unique_final <- data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = latitude),
longitude = as.numeric(x = longitude),
sign_latitude = dplyr::case_when(
sign(x = latitude) %in% c(0, +1) ~ "",
TRUE ~ "-"
),
latitude_degree = abs(x = trunc(x = latitude)),
latitude_minute = trunc((abs(x = latitude) - latitude_degree) * 60),
latitude_seconde = (abs(x = latitude) - latitude_degree - latitude_minute / 60) * 3600,
latitude_degree_minute_seconde = paste0(sign_latitude,
latitude_degree,
"d",
latitude_minute,
"'",
round(x = latitude_seconde),
"''"),
sign_longitude = dplyr::case_when(
sign(x = longitude) %in% c(0, +1) ~ "",
TRUE ~ "-"
),
longitude_degree = abs(x = trunc(x = longitude)),
longitude_minute = trunc((abs(x = longitude) - longitude_degree) * 60),
longitude_seconde = (abs(x = longitude) - longitude_degree - longitude_minute / 60) * 3600,
longitude_degree_minute_seconde = paste0(sign_longitude,
longitude_degree,
"d",
longitude_minute,
"'",
round(x = longitude_seconde),
"''")) %>%
dplyr::ungroup()%>%
dplyr::select(cwp,
latitude_degree_minute_seconde,
longitude_degree_minute_seconde)
}
} else {
data_cwp_unique_final <- dplyr::mutate(.data = data_cwp_unique_final,
latitude = NA,
longitude = NA) %>%
dplyr::select(-geometry)
}
data_final <- dplyr::left_join(x = data_cwp,
y = data_cwp_unique_final,
by = "cwp")
} else {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, function not developed yet for cwp of length ",
cwp_length,
".\n"))
}
}
} else if (manipulation_process == "latitude_longitude_to_cwp") {
# data_latitude argument checking
if (codama::r_type_checking(r_object = data_latitude,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_latitude,
type = "character",
output = "message"))
}
# data_longitude argument checking
if (codama::r_type_checking(r_object = data_longitude,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_longitude,
type = "character",
output = "message"))
}
if (length(x = data_longitude) != length(x = data_latitude)) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid \"data_longitude\" and \"data_latitude\" arguments, same length argument expected.\n"))
}
# input_degree_format argument checking
if (codama::r_type_checking(r_object = input_degree_format,
type = "character",
length = 1L,
allowed_value = c("degree_minute_seconde",
"decimal_degree"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = input_degree_format,
type = "character",
length = 1L,
allowed_value = c("degree_minute_seconde",
"decimal_degree"),
output = "message"))
}
# output_cwp_format argument checking
if (input_degree_format == "decimal_degree") {
longitude_data <- data_longitude
latitude_data <- data_latitude
} else {
longitude_data <- sapply(X = seq_len(length.out = length(data_longitude)),
FUN = function(d) {
current_longitude <- data_longitude[d]
sign_current_longitude <- ifelse(test = sign(x = as.integer(regmatches(current_longitude,
regexpr("[^d]*",
current_longitude)))) %in% c(0, +1),
yes = "",
no = "-")
current_longitude_degree <- regmatches(current_longitude,
regexpr("[^d]*",
current_longitude))
current_longitude_minute <- stringr::str_extract(string = current_longitude,
pattern = "(?<=d)[[:digit:]]{1,2}")
current_longitude_seconde <- gsub(pattern = ".*'(.+)''.*",
replacement = "\\1",
x = current_longitude)
current_longitude_decimal_degree <- abs(as.numeric(current_longitude_degree)) + as.numeric(current_longitude_minute) / 60 + as.numeric(current_longitude_seconde) / 3600
current_longitude_decimal_degree <- paste0(sign_current_longitude,
current_longitude_decimal_degree)
})
latitude_data <- sapply(X = seq_len(length.out = length(data_latitude)),
FUN = function(e) {
current_latitude <- data_latitude[e]
sign_current_latitude <- ifelse(test = sign(x = as.integer(regmatches(current_latitude,
regexpr("[^d]*",
current_latitude)))) %in% c(0, +1),
yes = "",
no = "-")
current_latitude_degree <- regmatches(current_latitude,
regexpr("[^d]*",
current_latitude))
current_latitude_minute <- stringr::str_extract(string = current_latitude,
pattern = "(?<=d)[[:digit:]]{1,2}")
current_latitude_seconde <- gsub(pattern = ".*'(.+)\".*",
replacement = "\\1",
x = current_latitude)
current_latitude_decimal_degree <- abs(as.numeric(current_latitude_degree)) + as.numeric(current_latitude_minute) / 60 + as.numeric(current_latitude_seconde) / 3600
current_latitude_decimal_degree <- paste0(sign_current_latitude,
current_latitude_decimal_degree)
})
}
data_latitude_longitude <- dplyr::tibble(longitude_decimal_degree = as.numeric(longitude_data),
latitude_decimal_degree = as.numeric(latitude_data))
data_latitude_longitude_unique <- unique(x = data_latitude_longitude)
data_latitude_longitude_unique$data_id <- seq_len(length.out = nrow(data_latitude_longitude_unique))
if (codama::r_type_checking(r_object = epsg_code,
type = "integer",
length = 1L,
output = "logical") != TRUE
|| nchar(x = epsg_code) != 4) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid \"epsg_code\" argument, class integer expected with one unique value inside.\n"))
}
longitude_latitude_sf <- sf::st_as_sf(x = data_latitude_longitude_unique,
coords = c("longitude_decimal_degree",
"latitude_decimal_degree"),
crs = epsg_code)
sf_join_longitude_latitude <- sf::st_join(x = longitude_latitude_sf,
y = reference_grid,
join = sf::st_intersects,
left = TRUE)
join_longitude_latitude <- sf::st_drop_geometry(sf_join_longitude_latitude)
join_longitude_latitude <- join_longitude_latitude[, c("data_id",
"CWP_CODE")]
if (nrow(x = data_latitude_longitude_unique) != nrow(x = join_longitude_latitude)) {
data_latitude_longitude_unique_duplicate <- dplyr::inner_join(x = data_latitude_longitude_unique,
y = join_longitude_latitude,
by = "data_id") %>%
dplyr::group_by(longitude_decimal_degree,
latitude_decimal_degree) %>%
dplyr::mutate(count = dplyr::n()) %>%
dplyr::filter(count != 1)
data_id_duplicate <- unique(data_latitude_longitude_unique_duplicate$data_id)
for (current_data_id in data_id_duplicate) {
current_data_latitude_longitude_unique_duplicate <- dplyr::filter(.data = data_latitude_longitude_unique_duplicate,
data_id == current_data_id)
current_sf_join_longitude_latitude <- dplyr::filter(.data = sf_join_longitude_latitude,
data_id == current_data_id)
if (length(x = unique(x = current_sf_join_longitude_latitude$CWP_B)) != 1) {
if (any(unique(x = current_sf_join_longitude_latitude$CWP_B) == 1)) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
CWP_B == 1)$CWP_CODE
} else {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
CWP_B %in% c(2, 4))$CWP_CODE
}
} else {
if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 1) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == min(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == min(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 2) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == min(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == max(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 3) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == max(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == max(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 4) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == max(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == min(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
}
}
join_longitude_latitude <- dplyr::filter(.data = join_longitude_latitude,
! (data_id == current_data_id
& CWP_CODE != best_cwp))
}
}
data_latitude_longitude_unique <- dplyr::inner_join(x = data_latitude_longitude_unique,
y = join_longitude_latitude,
by = "data_id")
data_final <- dplyr::tibble(dplyr::left_join(x = data_latitude_longitude,
y = data_latitude_longitude_unique,
by = c("longitude_decimal_degree",
"latitude_decimal_degree"))) %>%
dplyr::select(-data_id) %>%
dplyr::rename("cwp" = "CWP_CODE")
}
return(data_final)
}
OB7-IRD/furdeb documentation built on April 21, 2024, 12:17 a.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.
Defines functions latitude_longitude_cwp_manipulation
Documented in latitude_longitude_cwp_manipulation
#' @name latitude_longitude_cwp_manipulation
#' @title Conversion function for latitude, longitude and cwp item
#' @description Conversion function for latitude, longitude and cwp item. For more information on the cwp format check the online document on https://www.fao.org/cwp-on-fishery-statistics/handbook/general-concepts/main-water-areas/en/#c737533.
#' @param manipulation_process {\link[base]{character}} expected. A string matching one of the accepted processes. Available processes are "cwp_to_latitude_longitude" or "latitude_longitude_to_cwp".
#' @param data_longitude {\link[base]{character}} expected. By default NULL. Mandatory argument for "latitude_longitude_to_cwp" process. A string vector with longitude value(s). Formats allowed is decimal degree (with point separator) or in degree minute seconde format (xxdxx'xx''). If values are duplicated, the function simplify the process automatically (no need to remove them before).
#' @param data_latitude {\link[base]{character}} expected. By default NULL. Mandatory argument for "latitude_longitude_to_cwp" process. A string vector with latitude value(s). Formats allowed is decimal degree (with point separator) or in degree minute seconde format (xxdxx'xx''). If values are duplicated, the function simplify the process automatically (no need to remove them before).
#' @param data_cwp {\link[base]{character}} expected. By default NULL. Mandatory argument for "cwp_to_latitude_longitude" process. A string vector with cwp value(s).
#' @param referential_grid_file_path {\link[base]{character}} expected. File path of the referential grid shape. File with .Rdata extension file expected.
#' @param output_degree_format {\link[base]{character}} expected. By default NULL. Mandatory for "cwp_to_latitude_longitude" process. A string matching one of the accepted output degree format. Available formats are "degree_minute_seconde" and "decimal_degree".
#' @param output_degree_parameter {\link[base]{character}} expected. By default NULL. Mandatory for "cwp_to_latitude_longitude" process. You can choose between "centroid" or "corner" for display coordinates of the square according to the centroid or the corner of it.
#' @param input_degree_format {\link[base]{character}} expected. By default NULL. Mandatory for "latitude_longitude_to_cwp" process. A string matching one of the accepted output degree format. Available formats are "degree_minute_seconde" and "decimal_degree".
#' @param epsg_code {\link[base]{integer}} expected. By default 4326. Mandatory for "latitude_longitude_to_cwp" process. An integer (on 4 digits) of one EPSG spatial reference systems related to latitude and longitude coordinates provide. Check this web site for more informations: https://www.spatialreference.org. By default 4326.
#' @return Return a tibble.
#' @importFrom dplyr last tibble inner_join rowwise mutate ungroup select rename case_when left_join
#' @importFrom sf st_coordinates st_centroid st_as_sf st_join st_intersects st_drop_geometry
#' @importFrom stringr str_extract
#' @importFrom codama r_type_checking file_path_checking
#' @export
latitude_longitude_cwp_manipulation <- function(manipulation_process,
data_longitude = NULL,
data_latitude = NULL,
data_cwp = NULL,
referential_grid_file_path,
output_degree_format = NULL,
output_degree_parameter = NULL,
input_degree_format = NULL,
epsg_code = as.integer(4326)) {
# 1 - setup ----
suppressMessages(sf::sf_use_s2(use_s2 = FALSE))
# 2 - local binding global variables ----
geometry <- NULL
X <- NULL
Y <- NULL
latitude <- NULL
longitude <- NULL
latitude_degree <- NULL
latitude_minute <- NULL
sign_latitude <- NULL
latitude_seconde <- NULL
longitude_degree <- NULL
longitude_minute <- NULL
sign_longitude <- NULL
longitude_seconde <- NULL
cwp <- NULL
latitude_degree_minute_seconde <- NULL
latitude_decimal_degree <- NULL
longitude_degree_minute_seconde <- NULL
longitude_decimal_degree <- NULL
count <- NULL
data_id <- NULL
CWP_B <- NULL
X_COORD <- NULL
Y_COORD <- NULL
CWP_CODE <- NULL
# 3 - global arguments verifications ----
# manipulation_process argument checking
if (codama::r_type_checking(r_object = manipulation_process,
type = "character",
length = 1L,
allowed_value = c("latitude_longitude_to_cwp",
"cwp_to_latitude_longitude"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = manipulation_process,
type = "character",
length = 1L,
allowed_value = c("latitude_longitude_to_cwp",
"cwp_to_latitude_longitude"),
output = "message"))
}
# referential_grid_file_path argument checking
if (codama::file_path_checking(file_path = referential_grid_file_path,
extension = c("Rdata",
"RData"),
output = "logical") != TRUE) {
return(codama::file_path_checking(file_path = referential_grid_file_path,
extension = c("Rdata",
"RData"),
output = "message"))
}
# import reference grid ----
reference_grid <- get(x = load(file = referential_grid_file_path))
if (paste(class(reference_grid),
collapse = " ") != "sf tbl_df tbl data.frame") {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid fao shapefile, R object of class sf expected.\n"))
}
if (codama::r_type_checking(r_object = names(reference_grid),
type = "character",
allowed_value = c("CWP_CODE",
"GRIDTYPE",
"QUADRANT",
"X_Y_TYPE",
"X_COORD",
"Y_COORD",
"CWP_A",
"CWP_B",
"CWP_C",
"CWP_D",
"CWP_E",
"SURFACE",
"ON_SEA",
"ON_LAND",
"ON_LAND_P",
"ON_SEA_P",
"geometry"),
output = "logical") != TRUE) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid fao shapefile, use the function \"fao_shape_manipulation\" to prepare the grid the first time.\n"))
}
cwp_resolution <- unique(x = reference_grid$GRIDTYPE)
if (length(x = cwp_resolution) != 1) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, invalid \"reference_grid\" argument, multiple cwp resolutions inside the referential.\n"))
}
if (length(x = unique(sapply(X = reference_grid$CWP_CODE,
FUN = nchar))) != 1) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, invalid reference grid, CWP of multiple length inside the referential.\n"))
}
# 4 - Process ----
if (manipulation_process == "cwp_to_latitude_longitude") {
if (codama::r_type_checking(r_object = data_cwp,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_cwp,
type = "character",
output = "message"))
} else {
cwp_length <- unique(sapply(X = data_cwp,
FUN = nchar))
data_cwp <- dplyr::tibble(cwp = data_cwp)
data_cwp_unique <- unique(x = data_cwp)
if (cwp_length != unique(sapply(X = reference_grid$CWP_CODE,
FUN = nchar))) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
"- Error, dispencrecy between \"input_cwp_format\" argument and referential grid.\n"))
}
if (codama::r_type_checking(r_object = output_degree_format,
type = "character",
length = 1L,
allowed_value = c("decimal_degree",
"degree_minute_seconde"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = output_degree_format,
type = "character",
length = 1L,
allowed_value = c("decimal_degree",
"degree_minute_seconde"),
output = "message"))
}
if (codama::r_type_checking(r_object = output_degree_parameter,
type = "character",
length = 1L,
allowed_value = c("centroid",
"corner"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = output_degree_parameter,
type = "character",
length = 1L,
allowed_value = c("centroid",
"corner"),
output = "message"))
}
if (cwp_length %in% c(7)) {
data_cwp_unique_final <- dplyr::inner_join(x = data_cwp_unique,
y = reference_grid[, c("geometry",
"CWP_CODE")],
by = c("cwp" = "CWP_CODE"))
if (nrow(x = data_cwp_unique_final) != 0) {
if (output_degree_parameter == "centroid") {
data_cwp_unique_final <- suppressWarnings(data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = data.frame(sf::st_coordinates(x = sf::st_centroid(x = geometry)))$Y),
longitude = as.numeric(x = data.frame(sf::st_coordinates(x = sf::st_centroid(x = geometry)))$X)) %>%
dplyr::ungroup() %>%
dplyr::select(-geometry))
} else if (output_degree_parameter == "corner") {
data_cwp_unique_final <- suppressWarnings(data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = dplyr::distinct(data.frame(sf::st_coordinates(x = geometry)) %>%
mutate(X = round(x = abs(x = X),
digits = 2),
Y = round(x = abs(x = Y),
digits = 2)) %>%
dplyr::filter(X == min(X)) %>%
dplyr::filter(Y == min(Y))))[2],
longitude = as.numeric(x = dplyr::distinct(data.frame(sf::st_coordinates(x = geometry)) %>%
mutate(X = round(x = abs(x = X),
digits = 2),
Y = round(x = abs(x = Y),
digits = 2)) %>%
dplyr::filter(X == min(X)) %>%
dplyr::filter(Y == min(Y))))[1]) %>%
dplyr::ungroup() %>%
dplyr::select(-geometry))
}
if (output_degree_format == "decimal_degree") {
data_cwp_unique_final <- dplyr::rename(.data = data_cwp_unique_final,
latitude_decimal_degree = latitude,
longitude_decimal_degree = longitude)
} else if (output_degree_format == "degree_minute_seconde") {
data_cwp_unique_final <- data_cwp_unique_final %>%
dplyr::rowwise() %>%
dplyr::mutate(latitude = as.numeric(x = latitude),
longitude = as.numeric(x = longitude),
sign_latitude = dplyr::case_when(
sign(x = latitude) %in% c(0, +1) ~ "",
TRUE ~ "-"
),
latitude_degree = abs(x = trunc(x = latitude)),
latitude_minute = trunc((abs(x = latitude) - latitude_degree) * 60),
latitude_seconde = (abs(x = latitude) - latitude_degree - latitude_minute / 60) * 3600,
latitude_degree_minute_seconde = paste0(sign_latitude,
latitude_degree,
"d",
latitude_minute,
"'",
round(x = latitude_seconde),
"''"),
sign_longitude = dplyr::case_when(
sign(x = longitude) %in% c(0, +1) ~ "",
TRUE ~ "-"
),
longitude_degree = abs(x = trunc(x = longitude)),
longitude_minute = trunc((abs(x = longitude) - longitude_degree) * 60),
longitude_seconde = (abs(x = longitude) - longitude_degree - longitude_minute / 60) * 3600,
longitude_degree_minute_seconde = paste0(sign_longitude,
longitude_degree,
"d",
longitude_minute,
"'",
round(x = longitude_seconde),
"''")) %>%
dplyr::ungroup()%>%
dplyr::select(cwp,
latitude_degree_minute_seconde,
longitude_degree_minute_seconde)
}
} else {
data_cwp_unique_final <- dplyr::mutate(.data = data_cwp_unique_final,
latitude = NA,
longitude = NA) %>%
dplyr::select(-geometry)
}
data_final <- dplyr::left_join(x = data_cwp,
y = data_cwp_unique_final,
by = "cwp")
} else {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, function not developed yet for cwp of length ",
cwp_length,
".\n"))
}
}
} else if (manipulation_process == "latitude_longitude_to_cwp") {
# data_latitude argument checking
if (codama::r_type_checking(r_object = data_latitude,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_latitude,
type = "character",
output = "message"))
}
# data_longitude argument checking
if (codama::r_type_checking(r_object = data_longitude,
type = "character",
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = data_longitude,
type = "character",
output = "message"))
}
if (length(x = data_longitude) != length(x = data_latitude)) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid \"data_longitude\" and \"data_latitude\" arguments, same length argument expected.\n"))
}
# input_degree_format argument checking
if (codama::r_type_checking(r_object = input_degree_format,
type = "character",
length = 1L,
allowed_value = c("degree_minute_seconde",
"decimal_degree"),
output = "logical") != TRUE) {
return(codama::r_type_checking(r_object = input_degree_format,
type = "character",
length = 1L,
allowed_value = c("degree_minute_seconde",
"decimal_degree"),
output = "message"))
}
# output_cwp_format argument checking
if (input_degree_format == "decimal_degree") {
longitude_data <- data_longitude
latitude_data <- data_latitude
} else {
longitude_data <- sapply(X = seq_len(length.out = length(data_longitude)),
FUN = function(d) {
current_longitude <- data_longitude[d]
sign_current_longitude <- ifelse(test = sign(x = as.integer(regmatches(current_longitude,
regexpr("[^d]*",
current_longitude)))) %in% c(0, +1),
yes = "",
no = "-")
current_longitude_degree <- regmatches(current_longitude,
regexpr("[^d]*",
current_longitude))
current_longitude_minute <- stringr::str_extract(string = current_longitude,
pattern = "(?<=d)[[:digit:]]{1,2}")
current_longitude_seconde <- gsub(pattern = ".*'(.+)''.*",
replacement = "\\1",
x = current_longitude)
current_longitude_decimal_degree <- abs(as.numeric(current_longitude_degree)) + as.numeric(current_longitude_minute) / 60 + as.numeric(current_longitude_seconde) / 3600
current_longitude_decimal_degree <- paste0(sign_current_longitude,
current_longitude_decimal_degree)
})
latitude_data <- sapply(X = seq_len(length.out = length(data_latitude)),
FUN = function(e) {
current_latitude <- data_latitude[e]
sign_current_latitude <- ifelse(test = sign(x = as.integer(regmatches(current_latitude,
regexpr("[^d]*",
current_latitude)))) %in% c(0, +1),
yes = "",
no = "-")
current_latitude_degree <- regmatches(current_latitude,
regexpr("[^d]*",
current_latitude))
current_latitude_minute <- stringr::str_extract(string = current_latitude,
pattern = "(?<=d)[[:digit:]]{1,2}")
current_latitude_seconde <- gsub(pattern = ".*'(.+)\".*",
replacement = "\\1",
x = current_latitude)
current_latitude_decimal_degree <- abs(as.numeric(current_latitude_degree)) + as.numeric(current_latitude_minute) / 60 + as.numeric(current_latitude_seconde) / 3600
current_latitude_decimal_degree <- paste0(sign_current_latitude,
current_latitude_decimal_degree)
})
}
data_latitude_longitude <- dplyr::tibble(longitude_decimal_degree = as.numeric(longitude_data),
latitude_decimal_degree = as.numeric(latitude_data))
data_latitude_longitude_unique <- unique(x = data_latitude_longitude)
data_latitude_longitude_unique$data_id <- seq_len(length.out = nrow(data_latitude_longitude_unique))
if (codama::r_type_checking(r_object = epsg_code,
type = "integer",
length = 1L,
output = "logical") != TRUE
|| nchar(x = epsg_code) != 4) {
return(cat(format(x = Sys.time(),
"%Y-%m-%d %H:%M:%S"),
" - Error, invalid \"epsg_code\" argument, class integer expected with one unique value inside.\n"))
}
longitude_latitude_sf <- sf::st_as_sf(x = data_latitude_longitude_unique,
coords = c("longitude_decimal_degree",
"latitude_decimal_degree"),
crs = epsg_code)
sf_join_longitude_latitude <- sf::st_join(x = longitude_latitude_sf,
y = reference_grid,
join = sf::st_intersects,
left = TRUE)
join_longitude_latitude <- sf::st_drop_geometry(sf_join_longitude_latitude)
join_longitude_latitude <- join_longitude_latitude[, c("data_id",
"CWP_CODE")]
if (nrow(x = data_latitude_longitude_unique) != nrow(x = join_longitude_latitude)) {
data_latitude_longitude_unique_duplicate <- dplyr::inner_join(x = data_latitude_longitude_unique,
y = join_longitude_latitude,
by = "data_id") %>%
dplyr::group_by(longitude_decimal_degree,
latitude_decimal_degree) %>%
dplyr::mutate(count = dplyr::n()) %>%
dplyr::filter(count != 1)
data_id_duplicate <- unique(data_latitude_longitude_unique_duplicate$data_id)
for (current_data_id in data_id_duplicate) {
current_data_latitude_longitude_unique_duplicate <- dplyr::filter(.data = data_latitude_longitude_unique_duplicate,
data_id == current_data_id)
current_sf_join_longitude_latitude <- dplyr::filter(.data = sf_join_longitude_latitude,
data_id == current_data_id)
if (length(x = unique(x = current_sf_join_longitude_latitude$CWP_B)) != 1) {
if (any(unique(x = current_sf_join_longitude_latitude$CWP_B) == 1)) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
CWP_B == 1)$CWP_CODE
} else {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
CWP_B %in% c(2, 4))$CWP_CODE
}
} else {
if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 1) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == min(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == min(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 2) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == min(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == max(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 3) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == max(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == max(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
} else if (unique(x = current_sf_join_longitude_latitude$CWP_B) == 4) {
best_cwp <- dplyr::filter(.data = current_sf_join_longitude_latitude,
X_COORD == max(unique(x = current_sf_join_longitude_latitude$X_COORD))
& Y_COORD == min(unique(x = current_sf_join_longitude_latitude$Y_COORD)))$CWP_CODE
}
}
join_longitude_latitude <- dplyr::filter(.data = join_longitude_latitude,
! (data_id == current_data_id
& CWP_CODE != best_cwp))
}
}
data_latitude_longitude_unique <- dplyr::inner_join(x = data_latitude_longitude_unique,
y = join_longitude_latitude,
by = "data_id")
data_final <- dplyr::tibble(dplyr::left_join(x = data_latitude_longitude,
y = data_latitude_longitude_unique,
by = c("longitude_decimal_degree",
"latitude_decimal_degree"))) %>%
dplyr::select(-data_id) %>%
dplyr::rename("cwp" = "CWP_CODE")
}
return(data_final)
}
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.