Nothing
# nocov start
#' Walter & Lieth climatic diagram from normal climatology values
#'
#' @description
#' Plot of a Walter & Lieth climatic diagram from normal climatology data for
#' a station. This climatogram are great for showing a summary of climate
#' conditions for a place over a time period (1981-2010).
#'
#' @family aemet_plots
#' @family climatogram
#'
#' @param labels Character string as month labels for the X axis: `"en"`
#' (english), `"es"` (spanish), `"fr"` (french), etc.
#'
#' @param ggplot2 `TRUE/FALSE`. On `TRUE` the function uses
#' [ggclimat_walter_lieth()], if `FALSE` uses [`climatol::diagwl()`].
#'
#' @param ... Further arguments to
#' [`climatol::diagwl()`] or [ggclimat_walter_lieth()], depending on the
#' value of \CRANpkg{ggplot2}.
#'
#' @inheritParams climatestripes_station
#'
#' @inheritSection aemet_daily_clim API Key
#' @note
#' The code is based on code from the CRAN package \CRANpkg{climatol}.
#'
#' @references
#' - Walter, H. K., Harnickell, E., Lieth, F. H. H., & Rehder, H. (1967).
#' *Klimadiagramm-weltatlas*. Jena: Fischer, 1967.
#' - Guijarro J. A. (2023).
#' *climatol: Climate Tools (Series Homogenization and Derived Products)*. R
#' package version 4.0.0, <https://climatol.eu>.
#'
#' @return A plot.
#'
#' @examplesIf aemet_detect_api_key()
#' climatogram_normal("9434")
#' @export
climatogram_normal <- function(station, labels = "en", verbose = FALSE,
ggplot2 = TRUE, ...) {
if (verbose) {
message("Data download may take a few seconds ... please wait \n")
}
data_raw <-
aemet_normal_clim(station, verbose = verbose)
if (nrow(data_raw) == 0) {
stop("No valid results from the API")
}
data <- data_raw[c("mes", "p_mes_md", "tm_max_md", "tm_min_md", "ta_min_min")]
data$mes <- as.numeric(data$mes)
data <- data[data$mes < 13, ]
data <- tidyr::pivot_longer(data, 2:5)
data <- tidyr::pivot_wider(data, names_from = "mes", values_from = "value")
data <- dplyr::arrange(
data,
match("name", c("p_mes_md", "tm_max_md", "tm_min_md", "ta_min_min"))
)
# Need a data frame with row names
data <- as.data.frame(data)
rownames(data) <- data$name
data <- data[, colnames(data) != "name"]
stations <- aemet_stations(verbose = verbose)
stations <- stations[stations$indicativo == station, ]
data_na <- as.integer(sum(is.na(data)))
if (is.null(labels)) {
labels <- "en"
}
if (data_na > 0) {
message("Data with null values, unable to plot the diagram \n")
} else if (ggplot2 == TRUE) {
ggclimat_walter_lieth(
data,
est = stations$nombre,
alt = stations$altitud,
per = "1981-2010",
mlab = labels,
...
)
} else {
if (!requireNamespace("climatol", quietly = TRUE)) {
stop("\n\npackage climatol required, please install it first")
}
climatol::diagwl(
data,
est = stations$nombre,
alt = stations$altitud,
per = "1981-2010",
mlab = labels,
...
)
}
}
#' Walter & Lieth climatic diagram for a time period
#'
#' @description
#' Plot of a Walter & Lieth climatic diagram from monthly climatology data for
#' a station. This climatogram are great for showing a summary of climate
#' conditions for a place over a specific time period.
#'
#' @family aemet_plots
#' @family climatogram
#'
#' @inheritParams climatogram_normal
#' @inheritParams aemet_monthly_period
#'
#' @note The code is based on code from the CRAN package \CRANpkg{climatol}.
#'
#' @references
#' - Walter, H. K., Harnickell, E., Lieth, F. H. H., & Rehder, H. (1967).
#' *Klimadiagramm-weltatlas*. Jena: Fischer, 1967.
#' - Guijarro J. A. (2023).
#' *climatol: Climate Tools (Series Homogenization and Derived Products)*. R
#' package version 4.0.0, <https://climatol.eu>.
#'
#' @return A plot.
#'
#'
#' @examplesIf aemet_detect_api_key()
#' \donttest{
#' climatogram_period("9434", start = 2015, end = 2020, labels = "en")
#' }
#' @inheritSection aemet_daily_clim API Key
#'
#' @export
climatogram_period <- function(station = NULL, start = 1990, end = 2020,
labels = "en", verbose = FALSE, ggplot2 = TRUE,
...) {
data_raw <- aemet_monthly_period(station,
start = start,
end = end,
verbose = verbose
)
if (nrow(data_raw) == 0) {
stop("No valid results from the API")
}
data <- data_raw[c("fecha", "p_mes", "tm_max", "tm_min", "ta_min")]
data <- tidyr::drop_na(data, c("p_mes", "tm_max", "tm_min", "ta_min"))
data <- data[-grep("-13", data$fecha), ]
data$ta_min <- as.double(
gsub("\\s*\\([^\\)]+\\)", "", as.character(data$ta_min))
)
data$fecha <- as.Date(paste0(data$fecha, "-01"), format = "%Y-%m-%d")
data$mes <- as.integer(format(data$fecha, "%m"))
data <- data[names(data) != "fecha"]
data <- tibble::as_tibble(aggregate(. ~ mes, data, mean))
data <- tidyr::pivot_longer(data, 2:5)
data <- tidyr::pivot_wider(data, names_from = "mes", values_from = "value")
data <- dplyr::arrange(
data,
match("name", c("p_mes_md", "tm_max_md", "tm_min_md", "ta_min_min"))
)
# Need a data frame with row names
data <- as.data.frame(data)
rownames(data) <- data$name
data <- data[, colnames(data) != "name"]
stations <- aemet_stations(verbose = verbose)
stations <- stations[stations$indicativo == station, ]
data_na <- as.integer(sum(is.na(data)))
if (is.null(labels)) {
labels <- "en"
}
if (data_na > 0) {
message("Data with null values, unable to plot the diagram \n")
} else if (ggplot2) {
ggclimat_walter_lieth(
data,
est = stations$nombre,
alt = stations$altitud,
per = paste(start, "-", end),
mlab = labels,
...
)
} else {
if (!requireNamespace("climatol", quietly = TRUE)) {
stop("\n\npackage climatol required, please install it first")
}
climatol::diagwl(data,
est = stations$nombre,
alt = stations$altitud, per = paste(start, "-", end),
mlab = labels, cols = NULL, ...
)
}
}
#' Walter and Lieth climatic diagram on \CRANpkg{ggplot2}
#'
#' @description
#' Plot of a Walter and Lieth climatic diagram of a station. This function is
#' an updated version of [`climatol::diagwl()`], by Jose A. Guijarro.
#'
#' \if{html}{\figure{lifecycle-experimental.svg}{options: alt="[Experimental]"}}
#'
#' @export
#'
#' @family aemet_plots
#' @family climatogram
#'
#' @param dat Monthly climatic data for which the diagram will be plotted.
#'
#' @param est Name of the climatological station.
#'
#' @param alt Altitude of the climatological station.
#'
#' @param per Period on which the averages have been computed.
#' @param mlab Month labels for the X axis. Use 2-digit language code (`"en"`,
#' `"es"`, etc.). See [`readr::locale()`] for info.
#' @param pcol Color for precipitation.
#' @param tcol Color for temperature.
#' @param pfcol Fill color for probable frosts.
#' @param sfcol Fill color for sure frosts.
#' @param shem Set to `TRUE` for southern hemisphere stations.
#' @param p3line Set to `TRUE` to draw a supplementary precipitation line
#' referenced to three times the temperature (as suggested by Bogdan Rosca).
#' @param ... Other graphic parameters
#'
#' @seealso [`climatol::diagwl()`], [`readr::locale()`]
#'
#' @return A \CRANpkg{ggplot2} object. See `help("ggplot2")`.
#'
#' @references
#' - Walter, H. K., Harnickell, E., Lieth, F. H. H., & Rehder, H. (1967).
#' *Klimadiagramm-weltatlas*. Jena: Fischer, 1967.
#'
#' @details
#' See Details on [`climatol::diagwl()`].
#'
#' Climatic data must be passed as a 4x12 matrix or `data.frame` of monthly
#' (January to December) data, in the following order:
#' - Row 1: Mean precipitation.
#' - Row 2: Mean maximum daily temperature.
#' - Row 3: Mean minimum daily temperature.
#' - Row 4: Absolute monthly minimum temperature.
#'
#' See [climaemet_9434_climatogram] for a sample dataset.
#'
#' @inheritSection aemet_daily_clim API Key
#'
#' @examples
#'
#' library(ggplot2)
#'
#' wl <- ggclimat_walter_lieth(
#' climaemet::climaemet_9434_climatogram,
#' alt = "249",
#' per = "1981-2010",
#' est = "Zaragoza Airport"
#' )
#'
#' wl
#'
#' # As it is a ggplot object we can modify it
#'
#' wl + theme(
#' plot.background = element_rect(fill = "grey80"),
#' panel.background = element_rect(fill = "grey70"),
#' axis.text.y.left = element_text(
#' colour = "black",
#' face = "italic"
#' ),
#' axis.text.y.right = element_text(
#' colour = "black",
#' face = "bold"
#' )
#' )
ggclimat_walter_lieth <- function(dat, est = "", alt = NA, per = NA,
mlab = "es", pcol = "#002F70",
tcol = "#ff0000", pfcol = "#9BAEE2",
sfcol = "#3C6FC4", shem = FALSE,
p3line = FALSE,
...) {
## Validate inputs----
if (!all(dim(dat) == c(4, 12))) {
stop(
"`dat` should have 4 rows and 12 colums. Your inputs has ",
nrow(dat), " rows and ", ncol(dat), " columns."
)
}
# NULL data
data_na <- as.integer(sum(is.na(dat)))
if (data_na > 0) {
stop("Data with null values, unable to plot the diagram \n")
}
# If matrix transform to data frame
if (is.matrix(dat)) {
dat <- as.data.frame(dat,
row.names = c(
"p_mes_md", "tm_max_md", "tm_min_md",
"ta_min_min"
),
col.names = paste0("m", seq_len(12))
)
}
## Transform data----
# Months label
mlab <- toupper(substr(readr::locale(mlab)$date_names$mon, 1, 1))
# Pivot table and tidydata
dat_long <- tibble::as_tibble(as.data.frame(t(dat)))
# Easier to handle, normalize names
names(dat_long) <- c("p_mes", "tm_max", "tm_min", "ta_min")
dat_long <- dplyr::bind_cols(label = mlab, dat_long)
# Southern hemisphere
if (shem) {
dat_long <- rbind(dat_long[7:12, ], dat_long[1:6, ])
}
# Mean temp
dat_long$tm <- (dat_long[[3]] + dat_long[[4]]) / 2
# Reescalate p_mes
dat_long$pm_reesc <- ifelse(dat_long$p_mes < 100,
dat_long$p_mes * 0.5,
dat_long$p_mes * 0.05 + 45
)
# Add p3line
dat_long$p3line <- dat_long$p_mes / 3
# Add first and last row for plotting properly
dat_long <- dplyr::bind_rows(
dat_long[nrow(dat_long), ],
dat_long,
dat_long[1, ]
)
dat_long[c(1, nrow(dat_long)), "label"] <- ""
# Interpolate values to expand x range
# Number rows
dat_long <- cbind(indrow = seq(-0.5, 12.5, 1), dat_long)
dat_long_int <- NULL
for (j in seq(nrow(dat_long) - 1)) {
intres <- NULL
for (i in seq_len(ncol(dat_long))) {
if (is.character(dat_long[j, i])) {
# On character don't interpolate
val <- as.data.frame(dat_long[j, i])
} else {
# Interpolate
interpol <- approx(
x = dat_long[c(j, j + 1), 1],
y = dat_long[c(j, j + 1), i],
n = 50
)
val <-
as.data.frame(interpol$y) # Just the interpolated value
}
names(val) <- names(dat_long)[i]
intres <- dplyr::bind_cols(intres, val)
}
dat_long_int <- dplyr::bind_rows(dat_long_int, intres)
}
# Regenerate and filter values
dat_long_int$interpolate <- TRUE
dat_long_int$label <- ""
dat_long$interpolate <- FALSE
dat_long_int <-
dat_long_int[!dat_long_int$indrow %in% dat_long$indrow, ]
dat_long_end <- dplyr::bind_rows(dat_long, dat_long_int)
dat_long_end <- dat_long_end[order(dat_long_end$indrow), ]
dat_long_end <- dat_long_end[
dat_long_end$indrow >= 0 & dat_long_end$indrow <= 12,
]
dat_long_end <- tibble::as_tibble(dat_long_end)
# Final tibble with normalized and helper values
# Labels and axis----
## Horizontal axis ----
month_breaks <- dat_long_end[dat_long_end$label != "", ]$indrow
month_labs <- dat_long_end[dat_long_end$label != "", ]$label
## Vert. Axis range - temp ----
ymax <- max(60, 10 * floor(max(dat_long_end$pm_reesc) / 10) + 10)
# Min range
ymin <- min(-3, min(dat_long_end$tm)) # min Temp
range_tm <- seq(0, ymax, 10)
if (ymin < -3) {
ymin <- floor(ymin / 10) * 10 # min Temp rounded
# Labels
range_tm <- seq(ymin, ymax, 10)
}
# Labels
templabs <- paste0(range_tm)
templabs[range_tm > 50] <- ""
# Vert. Axis range - prec
range_prec <- range_tm * 2
range_prec[range_tm > 50] <- range_tm[range_tm > 50] * 20 - 900
preclabs <- paste0(range_prec)
preclabs[range_tm < 0] <- ""
## Titles and additional labels----
title <- est
if (!is.na(alt)) {
title <- paste0(
title, " (",
prettyNum(alt, big.mark = ",", decimal.mark = "."), " m)"
)
}
if (!is.na(per)) {
title <- paste0(title, "\n", per)
}
# Subtitles
sub <-
paste(round(mean(dat_long_end[dat_long_end$interpolate == FALSE, ]$tm), 1),
"C ",
prettyNum(
round(sum(
dat_long_end[dat_long_end$interpolate == FALSE, ]$p_mes
)),
big.mark = ","
),
" mm",
sep = ""
)
# Vertical tags
maxtm <- prettyNum(round(max(dat_long_end$tm_max), 1))
mintm <- prettyNum(round(min(dat_long_end$tm_min), 1))
tags <- paste0(
paste0(rep(" \n", 6), collapse = ""),
maxtm,
paste0(rep(" \n", 10), collapse = ""),
mintm
)
# Helper for ticks
ticks <- data.frame(
x = seq(0, 12),
ymin = -3,
ymax = 0
)
# Lines and additional areas----
getpolymax <- function(x, y, y_lim) {
initpoly <- FALSE
yres <- NULL
xres <- NULL
# Check
for (i in seq_len(length(y))) {
lastobs <- i == length(x)
# If conditions to plot polygon
if (y[i] > y_lim[i]) {
if (isFALSE(initpoly)) {
# Initialise polygon if not already initialise
xres <- c(xres, x[i])
yres <- c(yres, y_lim[i])
initpoly <- TRUE
}
xres <- c(xres, x[i])
yres <- c(yres, y[i])
# On lastobs we need to close the polygon
if (lastobs) {
xres <- c(xres, x[i], NA)
yres <- c(yres, y_lim[i], NA)
}
} else {
# Close polygon
if (initpoly) {
xres <- c(xres, x[i - 1], NA)
yres <- c(yres, y_lim[i - 1], NA)
initpoly <- FALSE
}
}
}
poly <- tibble::tibble(x = xres, y = yres)
return(poly)
}
getlines <- function(x, y, y_lim) {
yres <- NULL
xres <- NULL
ylim_res <- NULL
# Check
for (i in seq_len(length(y))) {
# If conditions to line
if (y[i] > y_lim[i]) {
xres <- c(xres, x[i])
yres <- c(yres, y[i])
ylim_res <- c(ylim_res, y_lim[i])
}
}
line <- tibble::tibble(
x = xres,
y = yres,
ylim_res = ylim_res
)
return(line)
}
prep_max_poly <- getpolymax(
x = dat_long_end$indrow,
y = pmax(dat_long_end$pm_reesc, 50),
y_lim = rep(50, length(dat_long_end$indrow))
)
tm_max_line <- getlines(
x = dat_long_end$indrow,
y = dat_long_end$tm,
y_lim = dat_long_end$pm_reesc
)
pm_max_line <- getlines(
x = dat_long_end$indrow,
y = pmin(dat_long_end$pm_reesc, 50),
y_lim = dat_long_end$tm
)
# Prob freeze
dat_real <-
dat_long_end[dat_long_end$interpolate == FALSE, c("indrow", "ta_min")]
x <- NULL
y <- NULL
for (i in seq_len(nrow(dat_real))) {
if (dat_real[i, ]$ta_min < 0) {
x <-
c(
x,
NA,
rep(dat_real[i, ]$indrow - 0.5, 2),
rep(dat_real[i, ]$indrow + 0.5, 2),
NA
)
y <- c(y, NA, -3, 0, 0, -3, NA)
} else {
x <- c(x, NA)
y <- c(y, NA)
}
}
probfreeze <- tibble::tibble(x = x, y = y)
rm(dat_real)
# Sure freeze
dat_real <-
dat_long_end[dat_long_end$interpolate == FALSE, c("indrow", "tm_min")]
x <- NULL
y <- NULL
for (i in seq_len(nrow(dat_real))) {
if (dat_real[i, ]$tm_min < 0) {
x <-
c(
x,
NA,
rep(dat_real[i, ]$indrow - 0.5, 2),
rep(dat_real[i, ]$indrow + 0.5, 2),
NA
)
y <- c(y, NA, -3, 0, 0, -3, NA)
} else {
x <- c(x, NA)
y <- c(y, NA)
}
}
surefreeze <- tibble::tibble(x = x, y = y)
# Start plotting----
# Basic lines and segments
wandlplot <- ggplot2::ggplot() +
ggplot2::geom_line(
data = dat_long_end,
aes(x = .data$indrow, y = .data$pm_reesc),
color = pcol
) +
ggplot2::geom_line(
data = dat_long_end,
aes(x = .data$indrow, y = .data$tm),
color = tcol
)
if (nrow(tm_max_line > 0)) {
wandlplot <- wandlplot +
ggplot2::geom_segment(
aes(
x = .data$x,
y = .data$ylim_res,
xend = .data$x,
yend = .data$y
),
data = tm_max_line,
color = tcol,
alpha = 0.2
)
}
if (nrow(pm_max_line > 0)) {
wandlplot <- wandlplot +
ggplot2::geom_segment(
aes(
x = .data$x,
y = .data$ylim_res,
xend = .data$x,
yend = .data$y
),
data = pm_max_line,
color = pcol,
alpha = 0.2
)
}
if (p3line) {
wandlplot <- wandlplot +
ggplot2::geom_line(
data = dat_long_end,
aes(
x = .data$indrow,
y = .data$p3line
),
color = pcol
)
}
# Add polygons
# Max precip
if (max(dat_long_end$pm_reesc) > 50) {
wandlplot <- wandlplot +
ggplot2::geom_polygon(
data = prep_max_poly,
aes(x, y), fill = pcol
)
}
# Probable freeze
if (min(dat_long_end$ta_min) < 0) {
wandlplot <- wandlplot +
ggplot2::geom_polygon(
data = probfreeze,
aes(x = x, y = y),
fill = pfcol,
colour = "black"
)
}
# Sure freeze
if (min(dat_long_end$tm_min) < 0) {
wandlplot <- wandlplot +
geom_polygon(
data = surefreeze,
aes(x = x, y = y),
fill = sfcol,
colour = "black"
)
}
# Add lines and scales to chart
wandlplot <- wandlplot +
geom_hline(yintercept = c(0, 50), size = 0.5) +
geom_segment(data = ticks, aes(
x = x,
xend = x,
y = ymin,
yend = ymax
)) +
scale_x_continuous(
breaks = month_breaks,
name = "",
labels = month_labs,
expand = c(0, 0)
) +
scale_y_continuous(
"C",
limits = c(ymin, ymax),
labels = templabs,
breaks = range_tm,
sec.axis = dup_axis(
name = "mm",
labels = preclabs
)
)
# Add tags and theme
wandlplot <- wandlplot +
ggplot2::labs(
title = title,
subtitle = sub,
tag = tags
) +
ggplot2::theme_classic() +
ggplot2::theme(
plot.title = element_text(
lineheight = 1,
size = 14,
face = "bold"
),
plot.subtitle = element_text(
hjust = 1,
vjust = 1,
size = 14
),
plot.tag = element_text(size = 10),
plot.tag.position = "left",
axis.ticks.length.x.bottom = unit(0, "pt"),
axis.line.x.bottom = element_blank(),
axis.title.y.left = element_text(
angle = 0,
vjust = 0.9,
size = 10,
colour = tcol,
margin = unit(rep(10, 4), "pt")
),
axis.text.x.bottom = element_text(size = 10),
axis.text.y.left = element_text(colour = tcol, size = 10),
axis.title.y.right = element_text(
angle = 0,
vjust = 0.9,
size = 10,
colour = pcol,
margin = unit(rep(10, 4), "pt")
),
axis.text.y.right = element_text(colour = pcol, size = 10)
)
return(wandlplot)
}
# nocov end
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.