-
Notifications
You must be signed in to change notification settings - Fork 10
/
Copy pathget_scale_data.R
150 lines (147 loc) · 6.17 KB
/
get_scale_data.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
#' Get geological timescale data
#'
#' This function takes a name of a geological timescale and returns data for the
#' timescale. Valid names include those of built-in `data.frames` ([periods()],
#' [epochs()], [stages()], [eons()], or [eras()]), partial matches of those
#' names (e.g., "per" or "age"), and partial or exact matches to those hosted
#' by Macrostrat (see Details below). Note that the colors in the built-in
#' `data.frames` are according to the Commission for the Geological Map of the
#' World. If you would like to obtain custom Macrostrat colors that are better
#' for mapping, you should specify the full name of a timescale (e.g.,
#' "international periods") and set `true_colors` to `FALSE`. Note that these
#' colors only vary for the Precambrian.
#'
#' @details The following timescales are available from the Macrostrat API as of
#' `r Sys.Date()`:
#' \itemize{
#' `r macrostrat_timescales()`
#' }
#'
#' The most up-to-date list can be found via the Macrostrat API [here](https://macrostrat.org/api/defs/timescales?all).
#'
#' @param name The name of the desired timescale.
#' @param true_colors Return original international time scale colors? (as
#' opposed to custom Macrostrat plotting colors)
#' @return A `data.frame` with the following columns:
#' \item{name}{the names of the time intervals}
#' \item{max_age}{the oldest boundaries of the time intervals, in millions of
#' years}
#' \item{min_age}{the youngest boundaries of the time intervals, in millions
#' of years}
#' \item{abbr}{either traditional abbreviations of the names of the time
#' intervals (if they exist) or custom abbreviations created with R}
#' \item{color}{hex color codes associated with the time intervals (if
#' applicable)}
#' \item{lab_color}{default label colors for the time interals, either white
#' or black, whichever has better contrast with the background color, based
#' on [recommendations by the International Telecommunication Union](https://www.itu.int/rec/R-REC-BT.601-7-201103-I/en)}
#' @importFrom utils read.csv
#' @importFrom curl nslookup
#' @export
get_scale_data <- function(name, true_colors = TRUE) {
check_required(name)
check_bool(true_colors)
possible_names <- c("periods", "epochs", "stages", "eras", "eons")
name_match <- grep(name, possible_names, ignore.case = TRUE)
if (length(name_match) > 0) {
if (length(name_match) > 1) {
cli::cli_abort("`name` matches multiple built-in timescales. Please be
more specific.")
} else {
name <- possible_names[name_match]
if (name == "periods") {
dat <- deeptime::periods
} else if (name == "epochs") {
dat <- deeptime::epochs
} else if (name == "stages") {
dat <- deeptime::stages
} else if (name == "eras") {
dat <- deeptime::eras
} else if (name == "eons") {
dat <- deeptime::eons
}
}
} else {
# try to get the timescale from macrostrat
# check that we are online and macrostrat is online
tryCatch(# nocov start
{
nslookup("macrostrat.org")
},
error = function(e) {
cli::cli_abort("Macrostrat is not available. Either the site is down or
you are not connected to the internet.")
}
)# nocov end
avail_scales <- read.csv(url(paste0("https://macrostrat.org/api/v2/defs/",
"timescales?all&format=csv")),
stringsAsFactors = FALSE)
# check exact matches
name_match <- match(tolower(name), tolower(avail_scales$timescale))
if (is.na(name_match)) {
# check partial matches
name_match <- grep(name, avail_scales$timescale, ignore.case = TRUE)
if (length(name_match) == 0) {
cli::cli_abort("`name` does not match a built-in or Macrostrat
timescale.")
} else if (length(name_match) > 1) {
cli::cli_abort("`name` matches multiple Macrostrat timescales. Please be
more specific.")
}
}
# get full timescale name and retrieve data from Macrostrat
name <- avail_scales$timescale[name_match]
URL <- url(paste0("https://macrostrat.org/api/v2/defs/intervals",
"?format=csv×cale=", gsub(" ", "%20", name),
ifelse(true_colors, "&true_colors=true", "")))
raw_dat <- tryCatch(
{
read.csv(URL, header = TRUE, stringsAsFactors = FALSE)
},
error = function(e) {# nocov start
cli::cli_abort("Macrostrat is not available. Either the site is down
or you are not connected to the internet.")
}# nocov end
)
clean_dat <- raw_dat[, c("name", "b_age", "t_age", "abbrev", "color")]
colnames(clean_dat) <- c("name", "max_age", "min_age", "abbr", "color")
no_abbr <- (is.na(clean_dat$abbr) | clean_dat$abbr == "")
clean_dat$abbr[no_abbr] <-
abbreviate(clean_dat$name, minlength = 1,
use.classes = TRUE, named = FALSE)[no_abbr]
dat <- clean_dat
dat$lab_color <- white_or_black(dat$color)
}
dat
}
# Determine best label colors based on luminance as per
# https://stackoverflow.com/a/1855903/4660582
# values are from https://www.itu.int/rec/R-REC-BT.601-7-201103-I/en
#' @importFrom grDevices col2rgb
white_or_black <- function(colors) {
rgbs <- col2rgb(colors)
luminance <- apply(rgbs, 2, function(x) {
(0.299 * x[1] + 0.587 * x[2] + 0.114 * x[3]) / 255
})
ifelse(luminance > .5, "black", "white")
}
# generate docs for available Macrostrat timescales
macrostrat_timescales <- function() {# nocov start
scales <- read.csv(url(paste0("https://macrostrat.org/api/v2/defs/timescales",
"?all&format=csv")),
stringsAsFactors = FALSE)
return(paste0("\\item ", scales$timescale, collapse = "\n"))
}# nocov end
#' Get geological timescale data
#'
#' @description
#' `r lifecycle::badge("deprecated")`
#'
#' `getScaleData()` was renamed to [get_scale_data()] as of **deeptime** version
#' 1.0.0 to create a more consistent API.
#' @keywords internal
#' @export
getScaleData <- function(name) {
lifecycle::deprecate_warn("1.0.0", "getScaleData()", "get_scale_data()")
get_scale_data(name)
}