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
}

Read our documentation on viewing source code .

Loading