-
Notifications
You must be signed in to change notification settings - Fork 4
/
types.castDate.R
116 lines (96 loc) · 4.72 KB
/
types.castDate.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
#' @title Cast date
#' @description cast date without a time
#' @param format available options are "default", "any", and "<pattern>" where
#' \describe{
#' \item{\code{default }}{An ISO8601 format string
#' \itemize{
#' \item{\code{date:}}{ This \code{MUST} be in ISO8601 format YYYY-MM-DD}
#' \item{\code{datetime:}}{ a date-time. This \code{MUST} be in ISO 8601 format of YYYY-MM-DDThh:mm:ssZ in UTC time}
#' \item{\code{time:}}{ a time without a date}
#' }}
#' \item{\code{any }}{Any parsable representation of the type. The implementing library
#' can attempt to parse the datetime via a range of strategies, e.g. \href{https://CRAN.R-project.org/package=lubridate}{lubridate},
#' \href{https://CRAN.R-project.org/package=parsedate}{parsedate},\code{\link[base]{strptime}},
#' \code{\link[base]{DateTimeClasses}}.}
#' \item{\code{<pattern> }}{date/time values in this field can be parsed according to \code{pattern}.
#' \code{<pattern>} MUST follow the syntax of \code{\link[base]{strptime}}.
#' (That is, values in the this field should be parseable by R using \code{<pattern>}).}
#' }
#' @param value date to cast
#' @rdname types.castDate
#' @export
#' @seealso \href{https://specs.frictionlessdata.io//table-schema/#date}{Types and formats specifications},
#' \code{\link[base]{strptime}}, \code{\link[base]{DateTimeClasses}},
#' \code{\link[parsedate]{parsedate-package}} and
#' \code{\link[lubridate]{lubridate-package}}.
#'
#' @examples
#' types.castDate(format = "default", value = as.Date("2019-1-1"))
#'
#' types.castDate(format = "default", value = "2019-1-1")
#'
#' types.castDate(format = "any", value = "2019-1-1")
#'
#' types.castDate(format = "%d/%m/%y", value = "21/11/06")
#'
#' types.castDate(format = "%d/%m/%y", value = as.Date("2019-1-1"))
#'
types.castDate <- function(format = "default", value) {
if (!lubridate::is.Date(value)) {
if (!is.character(value))
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
withCallingHandlers(
tryCatch({
if (is.null(format) ||
format == "default" || format == "any" || format == "%Y-%m-%d") {
value <- suppressWarnings(as.Date(
lubridate::parse_date_time(x = value, orders = "%Y-%m-%d"),
format = "%Y-%m-%d"
))
if (is.na(value) | is.null(value)) return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
} else if (format != "default" &&
!startsWith(format, "fmt:")) {
#format == "any"
if (format == "invalid") {
value <- strptime(x = value, format = format)
} else
value <- suppressWarnings(as.Date(lubridate::parse_date_time(value, format), format = format))
if (isTRUE(is.na(value) ||
nchar(value) > 11))
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
} else {
if (startsWith(format, "fmt:")) {
message(config::get("WARNING", file = system.file("config/config.yml", package = "tableschema.r")))
#warn=message("Format ",format," is deprecated.\nPlease use ",unlist(strsplit(format,":"))[2]," without 'fmt:' prefix.", call. = FALSE)
format <- trimws(gsub("fmt:", "", format), which = "both")
}
if (format == "invalid") {
value <- strptime(x = value, format = format)
}
#else
# value = as.Date(lubridate::parse_date_time(value, format), format = format)
if (isTRUE(is.na(value) ||
nchar(value) > 11))
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
}
if (!lubridate::is.Date(value)) {
parsed_effort <- suppressWarnings(lubridate::parse_date_time(value, format))
if ((!lubridate::is.instant(parsed_effort)) ||
is.na(parsed_effort)) {
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
} else {
value <- as.Date(lubridate::parse_date_time(value, format), format = format)
}
}
}),
warning = function(w) {
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
},
error = function(e) {
return(config::get("ERROR", file = system.file("config/config.yml", package = "tableschema.r")))
invokeRestart("muffleWarning")
}
)
}
return(value)
}