attachment:romanDates.R of R Coding/local-package

   1 #' Check Validity of Dates with Roman Numerial Month
   2 #'
   3 #' Check string is a valid date with Roman numerial month.
   4 #' @param x A character string
   5 #' @param sep Punctuation between day-month-year. Defaults to fullstop.
   6 #' @param pad Whether days should be padded with leading 0s. Defaults to TRUE.
   7 #' @return If the supplied string parses to Roman date, returns TRUE with the \code{"names"} attribute set to the date formatted with numerical month for later pocessing, if needed. If the the day is not correctly zero-padded, then FALSE is returned. If the date is invalid, then NA is returned.
   8 #' @examples
   9 #' isRomanDate("02.X.2018")
  10 #' isRomanDate("3-V-2015", sep="-", pad=FALSE)
  11 #' isRomanDate("21.IIII.2018") # invalid Roman number, FALSE returned
  12 #' isRomanDate("31.II.2018") # invalid days in month, NA returned
  13 #' @export
  14 isRomanDate <- function(x, sep = '.', pad = TRUE)
  15 {
  16 	if (length(x) > 1L)
  17 		message("argument 'x' has length > 1 and only the first element will be used")
  18 	x <- x[[1]]
  19 	day.pad <- sprintf("%02s", 1:9)
  20 	month.num <- sprintf("%02s", 1:12)
  21 	month.roman <- as.character(as.roman(month.num))
  22 	month.pattern <- paste(month.roman, collapse = '|')
  23 	date.pattern <- sprintf('[[:digit:]]{1,2}[%s](%s)[%s][[:digit:]]{4}', sep, month.pattern, sep)
  24 	result <- grepl(date.pattern, x, perl=TRUE)
  25 	if (result) {
  26 		dmy <- unlist(strsplit(x, sep, fixed=TRUE))
  27 		if (pad && as.numeric(dmy[1]) < 10 && !(dmy[1] %in% day.pad))
  28 			return(FALSE)
  29 		dmy[2] <- month.num[month.roman == dmy[2]]
  30 		dmy <- paste(dmy[3:1], collapse='-')
  31 		result <- as.character(as.Date(dmy, '%Y-%m-%d'))
  32 		if (!is.na(result)) {
  33 			n <- result
  34 			result <- TRUE
  35 			names(result) <- n
  36 		}
  37 	}
  38 	return(result)
  39 }
  40 #' Check Vector of Possible Roman Dates
  41 #'
  42 #' Strings to be checked supplied as a character vector, or frequency vector with the \code{"names"} attribute.
  43 #' @param x A character vertor, or numerical vector with character strings supplied in the \code{"names"} attribute.
  44 #' @param sorted Whether to sort the returned list. Defaults to TRUE.
  45 #' @param sep Punctuation between day-month-year. Defaults to fullstop.
  46 #' @param pad Whether days should be padded with leading 0s. Defaults to TRUE.
  47 #' @return The function returns the same vector type as supplied. If a named frequency vector is supplied, the numerical frequencies are not altered. The character vector returned, either directly or as a \code{"names"} attribute, contains the the original strings appened with either "(?)" or "(??)". The former indicates the date is correct but the zero-padding of the day does not conform. The latter indicates the date is not valid (e.g., 31 days in a month with only 30 days).
  48 #'
  49 #' If sorted = TRUE, then dates sorted in ascending chronological order included dates that are valid but not zero-padded as requested. Invalid dates are placed at then end of the list.
  50 #' @examples
  51 #' rD.test <- 1:3
  52 #' names(rD.test) <- c('03.VX.2018', '05.VII.2018', '9.VIII.2018')
  53 #' romanDates(rD.test)
  54 #' @export
  55 romanDates <- function(x, sorted = TRUE, sep = '.', pad = TRUE) {
  56 	r <- list()
  57 	if (length(x) == 0)
  58 		return(list(x))
  59 	r$names <- x
  60 	if (is.numeric(x)) {
  61 		r$count <- x
  62 		r$names <- names(x)
  63 	}
  64 	r$date <- numeric()
  65 	r$pad <- logical()
  66 	r$order <- numeric()
  67 	for (i in r$names) {
  68 		r$date <- append(r$date, NA)
  69 		r$pad <- append(r$pad, FALSE)
  70 		ln = length(r$date)
  71 		valid <- isRomanDate(i, sep = sep, pad = pad)
  72 		if (is.na(valid))
  73 			next()
  74 		if (valid) {
  75 			r$date[ln] <- names(valid)
  76 			r$pad[ln] <- TRUE
  77 			next()
  78 		}
  79 		valid <- isRomanDate(i, sep = sep, pad = !pad)	
  80 		if (valid)
  81 			r$date[ln] <- names(valid)
  82 	}
  83 	r$order <- order(r$date)
  84 	r$names[!(is.na(r$date) | r$pad)] <- sprintf('%s (?)', r$names[!(is.na(r$date) | r$pad)])
  85 	r$names[is.na(r$date)] <- sprintf('%s (??)', r$names[is.na(r$date)])
  86 	if (is.numeric(x)) {
  87 		result <- r$count
  88 		names(result) <- r$names
  89 	} else result <- r$names
  90 	if (sorted)
  91 		result <- result[r$order]
  92 	return(result)
  93 }