weather.R at 949de69 ⋅ munterfinger/hereR

#' HERE Destination Weather API: Observations, Forecasts, Astronomy and Alerts
#'
#' Weather forecasts, reports on current weather conditions,
#' astronomical information and alerts at a specific location (coordinates or
#' location name) based on the HERE 'Destination Weather' API.
#' The information comes from the nearest available weather station and is not interpolated.
#'
#' @references
#' \href{https://developer.here.com/documentation/weather/topics/example-weather-observation.html}{HERE Destination Weather API: Observation}
#'
#' @param poi \code{sf} object or character, Points of Interest (POIs) of geometry type \code{POINT} or location names (e.g. cities or regions).
#' @param product character, weather product of the 'Destination Weather API'. Supported products: \code{"observation"}, \code{"forecast_hourly"}, \code{"forecast_astronomy"} and \code{"alerts"}.
#' @param url_only boolean, only return the generated URLs (\code{default = FALSE})?
#'
#' @return
#' An \code{sf} object containing the requested weather information at the nearest weather station.
#' The point geometry in the \code{sf} object is the location of the weather station.
#' @export
#'
#' @examples
#' # Provide an API Key for a HERE project
#' set_key("<YOUR API KEY>")
#'
#' # Observation
#' observation <- weather(poi = poi, product = "observation", url_only = TRUE)
#'
#' # Forecast
#' forecast <- weather(poi = poi, product = "forecast_hourly", url_only = TRUE)
#'
#' # Astronomy
#' astronomy <- weather(poi = poi, product = "forecast_astronomy", url_only = TRUE)
#'
#' # Alerts
#' alerts <- weather(poi = poi, product = "alerts", url_only = TRUE)
weather <- function(poi, product = "observation", url_only = FALSE) {

  # Checks
  .check_weather_product(product)
  .check_boolean(url_only)

  # Add API key
  url <- .add_key(
    url = "https://weather.ls.hereapi.com/weather/1.0/report.json?"
  )

  # Add product
  url = paste0(
    url,
    "&product=",
    product
  )

  # Check and preprocess location
  # Character location
  if (is.character(poi)) {
    .check_addresses(poi)
    poi[poi == ""] = NA
    url = paste0(
      url,
      "&name=",
      poi
    )
  # sf POINTs
  } else if ("sf" %in% class(poi)) {
    .check_points(poi)
    poi <- sf::st_coordinates(
      sf::st_transform(poi, 4326)
    )
    poi <- paste0(
      "&longitude=", poi[, 1], "&latitude=", poi[, 2]
    )
    url = paste0(
      url,
      poi
    )
  # Not valid
  } else {
    stop("Invalid input for 'poi'.")
  }

  # Return urls if chosen
  if (url_only) return(url)

  # Request and get content
  data <- .get_content(
    url = url
  )
  if (length(data) == 0) return(NULL)

  # Extract information
  if (product == "observation") {
    weather <- .extract_weather_observation(data)
  } else if (product == "forecast_hourly") {
    weather <- .extract_weather_forecast_hourly(data)
  } else if (product == "forecast_astronomy") {
    weather <- .extract_weather_forecast_astronomy(data)
  } else if (product == "alerts") {
    weather <- .extract_weather_alerts(data)
  }

  # Create sf, data.table, data.frame
  rownames(weather) <- NULL
  return(
    sf::st_set_crs(
      sf::st_as_sf(
        as.data.frame(weather),
        coords = c("lng", "lat")
      ), 4326
    )
  )
}

.extract_weather_observation <- function(data) {
  ids <- .get_ids(data)
  count <- 0
  observation <- data.table::rbindlist(
    lapply(data, function(con) {
      count <<- count + 1
      df <- jsonlite::fromJSON(con)
      station <- data.table::data.table(
        id = ids[count],
        station = df$observations$location$city[1],
        lng = df$observations$location$longitude[1],
        lat = df$observations$location$latitude[1],
        distance = df$observations$location$distance[1] * 1000,
        timestamp = .parse_datetime(df$observations$location$observation[[1]]$utcTime),
        state = df$observations$location$state[1],
        country = df$observations$location$country[1])
      obs <- df$observations$location$observation[[1]]
      obs <- obs[, !names(obs) %in% c(
        "skyDescription", "airDescription", "precipitationDesc",
        "temperatureDesc", "iconName", "iconLink", "windDesc", "icon",
        "country", "state", "city", "latitude", "longitude", "distance",
        "utcTime", "elevation"), ]
      obs[, c(4:9, 16, 17, 23, 24)] <-
        sapply(obs[, c(4:9, 16, 17, 23, 24)], as.numeric)
      return(
        cbind(station, obs)
      )
    })
  )
  return(observation)
}

.extract_weather_forecast_hourly <- function(data) {
  ids <- .get_ids(data)
  count <- 0
  dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
  forecast <- data.table::rbindlist(
    lapply(dfs, function(df) {
      count <<- count + 1
      station <- data.table::data.table(
        id = ids[count],
        station = df$hourlyForecasts$forecastLocation$city[1],
        lng = df$hourlyForecasts$forecastLocation$longitude[1],
        lat = df$hourlyForecasts$forecastLocation$latitude[1],
        distance = df$hourlyForecasts$forecastLocation$distance[1] * 1000,
        state = df$hourlyForecasts$forecastLocation$state[1],
        country = df$hourlyForecasts$forecastLocation$country[1]
      )
    })
  )
  forecast$forecast <- lapply(dfs, function(df)
    {df$hourlyForecasts$forecastLocation$forecast})
  return(forecast)
}

.extract_weather_forecast_astronomy <- function(data) {
  ids <- .get_ids(data)
  count <- 0
  dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
  astronomy <- data.table::rbindlist(
    lapply(dfs, function(df) {
      count <<- count + 1
      station <- data.table::data.table(
        id = ids[count],
        station = df$astronomy$city[1],
        lng = df$astronomy$longitude[1],
        lat = df$astronomy$latitude[1],
        tz = df$astronomy$timezone[1],
        state = df$astronomy$state[1],
        country = df$astronomy$country[1]
      )
    })
  )
  astronomy$astronomy <- lapply(dfs, function(df) {
    ast <- df$astronomy$astronomy
    ast$date <- as.Date(.parse_datetime(ast$utcTime))
    ast$utcTime <- NULL
    ast
    }
  )
  return(astronomy)
}

.extract_weather_alerts <- function(data) {
  ids <- .get_ids(data)
  count <- 0
  dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
  alerts <- data.table::rbindlist(
    lapply(dfs, function(df) {
      count <<- count + 1
      station <- data.table::data.table(
        id = ids[count],
        station = df$alerts$city[1],
        lng = df$alerts$longitude[1],
        lat = df$alerts$latitude[1],
        state = df$alerts$state[1],
        country = df$alerts$country[1]
      )
    })
  )
  alerts$alerts <- lapply(dfs, function(df)
    {df$alerts$alerts})
  return(alerts)
}

Read our documentation on viewing source code .

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

1		#' HERE Destination Weather API: Observations, Forecasts, Astronomy and Alerts
2		#'
3		#' Weather forecasts, reports on current weather conditions,
4		#' astronomical information and alerts at a specific location (coordinates or
5		#' location name) based on the HERE 'Destination Weather' API.
6		#' The information comes from the nearest available weather station and is not interpolated.
7		#'
8		#' @references
9		#' \href{https://developer.here.com/documentation/weather/topics/example-weather-observation.html}{HERE Destination Weather API: Observation}
10		#'
11		#' @param poi \code{sf} object or character, Points of Interest (POIs) of geometry type \code{POINT} or location names (e.g. cities or regions).
12		#' @param product character, weather product of the 'Destination Weather API'. Supported products: \code{"observation"}, \code{"forecast_hourly"}, \code{"forecast_astronomy"} and \code{"alerts"}.
13		#' @param url_only boolean, only return the generated URLs (\code{default = FALSE})?
14		#'
15		#' @return
16		#' An \code{sf} object containing the requested weather information at the nearest weather station.
17		#' The point geometry in the \code{sf} object is the location of the weather station.
18		#' @export
19		#'
20		#' @examples
21		#' # Provide an API Key for a HERE project
22		#' set_key("<YOUR API KEY>")
23		#'
24		#' # Observation
25		#' observation <- weather(poi = poi, product = "observation", url_only = TRUE)
26		#'
27		#' # Forecast
28		#' forecast <- weather(poi = poi, product = "forecast_hourly", url_only = TRUE)
29		#'
30		#' # Astronomy
31		#' astronomy <- weather(poi = poi, product = "forecast_astronomy", url_only = TRUE)
32		#'
33		#' # Alerts
34		#' alerts <- weather(poi = poi, product = "alerts", url_only = TRUE)
35		weather <- function(poi, product = "observation", url_only = FALSE) {
36
37		# Checks
38	1	.check_weather_product(product)
39	1	.check_boolean(url_only)
40
41		# Add API key
42	1	url <- .add_key(
43	1	url = "https://weather.ls.hereapi.com/weather/1.0/report.json?"
44		)
45
46		# Add product
47	1	url = paste0(
48	1	url,
49	1	"&product=",
50	1	product
51		)
52
53		# Check and preprocess location
54		# Character location
55	1	if (is.character(poi)) {
56	1	.check_addresses(poi)
57	0	poi[poi == ""] = NA
58	0	url = paste0(
59	0	url,
60	0	"&name=",
61	0	poi
62		)
63		# sf POINTs
64	1	} else if ("sf" %in% class(poi)) {
65	1	.check_points(poi)
66	1	poi <- sf::st_coordinates(
67	1	sf::st_transform(poi, 4326)
68		)
69	1	poi <- paste0(
70	1	"&longitude=", poi[, 1], "&latitude=", poi[, 2]
71		)
72	1	url = paste0(
73	1	url,
74	1	poi
75		)
76		# Not valid
77		} else {
78	1	stop("Invalid input for 'poi'.")
79		}
80
81		# Return urls if chosen
82	0	if (url_only) return(url)
83
84		# Request and get content
85	1	data <- .get_content(
86	1	url = url
87		)
88	0	if (length(data) == 0) return(NULL)
89
90		# Extract information
91	1	if (product == "observation") {
92	1	weather <- .extract_weather_observation(data)
93	1	} else if (product == "forecast_hourly") {
94	1	weather <- .extract_weather_forecast_hourly(data)
95	1	} else if (product == "forecast_astronomy") {
96	1	weather <- .extract_weather_forecast_astronomy(data)
97	1	} else if (product == "alerts") {
98	1	weather <- .extract_weather_alerts(data)
99		}
100
101		# Create sf, data.table, data.frame
102	1	rownames(weather) <- NULL
103	1	return(
104	1	sf::st_set_crs(
105	1	sf::st_as_sf(
106	1	as.data.frame(weather),
107	1	coords = c("lng", "lat")
108	1	), 4326
109		)
110		)
111		}
112
113		.extract_weather_observation <- function(data) {
114	1	ids <- .get_ids(data)
115	1	count <- 0
116	1	observation <- data.table::rbindlist(
117	1	lapply(data, function(con) {
118	1	count <<- count + 1
119	1	df <- jsonlite::fromJSON(con)
120	1	station <- data.table::data.table(
121	1	id = ids[count],
122	1	station = df$observations$location$city[1],
123	1	lng = df$observations$location$longitude[1],
124	1	lat = df$observations$location$latitude[1],
125	1	distance = df$observations$location$distance[1] * 1000,
126	1	timestamp = .parse_datetime(df$observations$location$observation[[1]]$utcTime),
127	1	state = df$observations$location$state[1],
128	1	country = df$observations$location$country[1])
129	1	obs <- df$observations$location$observation[[1]]
130	1	obs <- obs[, !names(obs) %in% c(
131	1	"skyDescription", "airDescription", "precipitationDesc",
132	1	"temperatureDesc", "iconName", "iconLink", "windDesc", "icon",
133	1	"country", "state", "city", "latitude", "longitude", "distance",
134	1	"utcTime", "elevation"), ]
135	1	obs[, c(4:9, 16, 17, 23, 24)] <-
136	1	sapply(obs[, c(4:9, 16, 17, 23, 24)], as.numeric)
137	1	return(
138	1	cbind(station, obs)
139		)
140		})
141		)
142	1	return(observation)
143		}
144
145		.extract_weather_forecast_hourly <- function(data) {
146	1	ids <- .get_ids(data)
147	1	count <- 0
148	1	dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
149	1	forecast <- data.table::rbindlist(
150	1	lapply(dfs, function(df) {
151	1	count <<- count + 1
152	1	station <- data.table::data.table(
153	1	id = ids[count],
154	1	station = df$hourlyForecasts$forecastLocation$city[1],
155	1	lng = df$hourlyForecasts$forecastLocation$longitude[1],
156	1	lat = df$hourlyForecasts$forecastLocation$latitude[1],
157	1	distance = df$hourlyForecasts$forecastLocation$distance[1] * 1000,
158	1	state = df$hourlyForecasts$forecastLocation$state[1],
159	1	country = df$hourlyForecasts$forecastLocation$country[1]
160		)
161		})
162		)
163	1	forecast$forecast <- lapply(dfs, function(df)
164	1	{df$hourlyForecasts$forecastLocation$forecast})
165	1	return(forecast)
166		}
167
168		.extract_weather_forecast_astronomy <- function(data) {
169	1	ids <- .get_ids(data)
170	1	count <- 0
171	1	dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
172	1	astronomy <- data.table::rbindlist(
173	1	lapply(dfs, function(df) {
174	1	count <<- count + 1
175	1	station <- data.table::data.table(
176	1	id = ids[count],
177	1	station = df$astronomy$city[1],
178	1	lng = df$astronomy$longitude[1],
179	1	lat = df$astronomy$latitude[1],
180	1	tz = df$astronomy$timezone[1],
181	1	state = df$astronomy$state[1],
182	1	country = df$astronomy$country[1]
183		)
184		})
185		)
186	1	astronomy$astronomy <- lapply(dfs, function(df) {
187	1	ast <- df$astronomy$astronomy
188	1	ast$date <- as.Date(.parse_datetime(ast$utcTime))
189	1	ast$utcTime <- NULL
190	1	ast
191		}
192		)
193	1	return(astronomy)
194		}
195
196		.extract_weather_alerts <- function(data) {
197	1	ids <- .get_ids(data)
198	1	count <- 0
199	1	dfs <- lapply(data, function(con) {jsonlite::fromJSON(con)})
200	1	alerts <- data.table::rbindlist(
201	1	lapply(dfs, function(df) {
202	1	count <<- count + 1
203	1	station <- data.table::data.table(
204	1	id = ids[count],
205	1	station = df$alerts$city[1],
206	1	lng = df$alerts$longitude[1],
207	1	lat = df$alerts$latitude[1],
208	1	state = df$alerts$state[1],
209	1	country = df$alerts$country[1]
210		)
211		})
212		)
213	1	alerts$alerts <- lapply(dfs, function(df)
214	1	{df$alerts$alerts})
215	1	return(alerts)
216		}