# --------------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : weekdaysPer.r # # Last Updated Funclist : 08 Feb 2015, 5:12 AM (Sunday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : data.table # # # # ------------------------------------------------------------------------------------------------------------------------------- # # # # weekday_decimal ( day, combine.53=TRUE ) # # getWeekdays ( abbreviate=FALSE ) # # daysInMonth ( d=Sys.Date() # # , m=as.numeric(format(d, "%m")), y=if (missing(d)) 1 else as.numeric(format(d, "%Y")), origin=.origin ) # # monthsDiff ( x, y, origin=.origin, verbose=TRUE ) # # toNumb ( D ) # # addWeekday_ ( DT, dateCols=getDateColNames(DT) # # , newCol.nms=sapply(dateCols, gsub, pat="(.*)date(.*)", repl="\\1weekday\\2", ignore.case=TRUE) # # , abbreviate=TRUE, origin=.origin ) # # inweek ( vectorOfDates, singleDate, wk=1 ) # # seq7Days ( start, origin="1970-01-01" ) # # WeekdaysInMonth ( month=Sys.Date(), year=format(Sys.Date(), "%Y"), abbreviate=TRUE, start=NULL, end=NULL # # , origin=.origin ) # # print.WeekdaysInMonth ( x, full=FALSE ) # # isWholeMonth ( start, end, warn.change=TRUE, origin=.origin ) # # WeekdaysStartingAt ( start=0, abbreviate=FALSE, factor=TRUE, dontWarnAboutSunday=FALSE ) # # getWdays ( ) # # # # # # # # ------------------------------------------------------------------------------------------------------------------------------- # # --------------------------------------------------------------------------------------------------------------------------------- # make_weeknumb_string <- function(d) { stopifnot(is.date_or_time(d)) ((as.numeric(format(d, "%d"))-1) / 7) %>% trunc %>% {. + 1} %>% sprintf("Week %02i", .) } monday_weekof <- function(D) { ## Returns the Monday prior to D ## Sundays are assigned to the previous week if (!is.Date(D)) D %<>% as.Date ## Monday is wday 1; ## If we subtract D's wday and add 1 (for off by one), that will bring us to the start of the week ## However, we want ot shift the start of the week to monday, and assign Sunday to the previous week. ## Hence the additional +1 D + (1 + 1 - wday(D)) } weekday_decimal <- function(day, combine.53=TRUE) { wk <- data.table::week(day) yr <- data.table::year(day) if (combine.53) { wh.53 <- wk == 53 yr[wh.53] <- yr[wh.53] + 1 wk[wh.53] <- 0.9953 # note that we have not divided by 100 yet wk[wk == 1] <- 0.9953 } return(yr + wk / 100) } addWeekday_ <- function(DT, dateCols=getDateColNames(DT), newCol.nms=sapply(dateCols, gsub, pat="(.*)date(.*)", repl="\\1weekday\\2", ignore.case=TRUE), abbreviate=TRUE, origin=.origin, start=0) { ## Do NOT use 'origin' here. The call to as.Date() is simply to get the levels. ## OLD # levels <- weekdays(as.Date(3 + (0:6), origin="1970-01-01"), abbreviate=abbreviate) ## NEW levels <- WeekdaysStartingAt(start=start, abbreviate=abbreviate, factor=TRUE) if (!length(dateCols)) { warning ("dateCols has no length. No modifications made") return(invisible(DT)) } if (any(newCol.nms %chin% names(DT))) stop ("Some newCol.nms are already columns of DT") if (!all(dateCols %chin% names(DT))) stop ("Some dateCols are not columns of DT") ## only keep date/posix calls not.dateCols <- !(DT[, sapply(.SD, is.date_or_time), .SDcols=dateCols]) if (any(not.dateCols)) { if (missing(dateCols)) { newCol.nms <- newCol.nms[!not.dateCols] dateCols <- dateCols[!not.dateCols] } else stop (warningCols("The following columns are neither either date nor time", not.dateCols)) } ## Check again if (!length(dateCols)) { warning ("dateCols has no length. No modifications made") return(invisible(DT)) } # DT[, (newCol.nms) := lapply(.SD, function(x) factor(weekdays(as.Date(x, origin=.origin), abbreviate=abbreviate), levels=levels)), .SDcols=dateCols] DT[, (newCol.nms) := lapply(.SD, function(x) factor(weekdays( as.Date(strftime(x, usetz=TRUE, format="%Y-%m-%d"), origin=origin) , abbreviate=abbreviate), levels=levels)), .SDcols=dateCols] return(invisible(DT)) } inweek <- function(vectorOfDates, singleDate, wk=1) { # returns logical vector same length as `vectorOfDates` # indicating which dates are within the week starting at (singleDate + 7*(wk-1)) # relativeToDate should be a single date startDate <- singleDate + 7 * (wk - 1) endDate <- startDate + 6 (startDate <= vectorOfDates) & (vectorOfDates <= endDate) } seq7Days <- function(start, origin="1970-01-01") { # Wrapper for a 7-day sequence from start if (length(start) > 1) return(sapply(start, seq7Days, origin=origin)) seq.Date(as.Date(start, origin=origin), length.out=7, by=1) } WeekdaysInMonth <- function(month=Sys.Date(), year=format(Sys.Date(), "%Y"), abbreviate=TRUE, start=NULL, end=NULL, origin=.origin) { ## either 'month' needs to be provided or both start & end if (is.null(month) && (is.null(start) || is.null(end))) stop("If 'month' is not specified, then both 'start' and 'end' must be specified.") ## Ensure month is an integer if (!is.null(month)) { ## if month is a string in the format of a month tried <- try(as.Date(month), silent=TRUE) if (!isErr(tried)) month <- as.Date(month, origin=origin) ## if month is a date, extract the month, as a string if (is.Date(month)) { if (missing(year)) year <- format(month, "%Y") month <- months(month) } ## Convert to number if (is.character(month)) month <- pmatch(tolower(month), tolower(months(seq.Date(as.Date("2010-01-01", origin=origin), as.Date("2010-12-31", origin=origin), by="month")))) } ## // end !(missing(month)) carry <- (month) %/% 12 month_plus_one <- (month+1) %% 12 month_plus_one[!month_plus_one] <- 12 if (is.null(end)) end <- as.Date(sprintf("%s-%02i-01", as.numeric(year) + carry, month_plus_one), origin=origin) - 1 if (is.null(start)) start <- as.Date(sprintf("%s-%02i-01", year, month), origin=origin) if (end < start) warning(sprintf("Are the dates correct?\n'end' (%s) is before 'start' (%s)", end, start)) ## All the days in the range days <- seq.Date(start, end, by="day") ## Count the number of days, by weekday res <- as.data.table(table(day=weekdays(days, TRUE))) ## Convert day to factor res[, day := factor(day, levels=WeekdaysStartingAt(0, abbreviate=abbreviate, dontWarnAboutSunday=TRUE))] setkey(res, "day") ## Add some extra info res[, "isWeekend" := grepl("^[sS]", day)] res[, perc := count / sum(count)] res[, win := pmatch(day, WeekdaysStartingAt(0, abbreviate=abbreviate)) - 1] TotalDays <- res[, sum(count)] TotalWeekdays <- res[!(isWeekend), sum(count)] TotalWeekendDays <- res[(isWeekend), sum(count)] TotalMTuThF <- res[c("Mon", "Tue", "Thu", "Fri")][, sum(count)] ## Set these as attributes data.table::setattr(res, "start", start) data.table::setattr(res, "end", end) data.table::setattr(res, "Totals", list(TotalDays=TotalDays, TotalWeekdays=TotalWeekdays, TotalWeekendDays=TotalWeekendDays, TotalMTuThF=TotalMTuThF)) classAppend_ (res, "WeekdaysInMonth") res } print.WeekdaysInMonth <- function(x, full=FALSE) { Totals <- attr(x, "Totals") start <- attr(x, "start") end <- attr(x, "end") out <-paste( if ( isWholeMonth(start, end) ) sprintf(" For the month of %s, %s", months(start), year(start)) else sprintf(" From %s to %s", start, end) , "\n -------------------" , sprintf("\n %s ..... total days", Totals$TotalDays) , sprintf("\n %s ..... weekdays", Totals$TotalWeekdays) , sprintf("\n %s ..... non-Wednesday weekdays", Totals$TotalMTuThF) , "\n -------------------" ) cat(out, "\n\n") ret <- copy(data.table(x)) if (!full) { ret[, perc := fwp(perc, 1)] ret[, c("isWeekend", "win") := NULL] } print(ret) return(invisible(x)) } isWholeMonth <- function(start, end, warn.change=TRUE, origin=.origin) { if (is.character(start)) { ## TODO: Check for intorduced NAs start <- as.Date(start, origin=origin) } if (!is.Date(start)) stop ("'start' sent to isWholeMonth() should be a Date or string") if (is.character(end)) { ## TODO: Check for intorduced NAs end <- as.Date(end, origin=origin) } if (!is.Date(end)) stop ("'start' sent to isWholeMonth() should be a Date or string") { ## TODO: Check for intorduced NAs start <- as.Date(start, origin=origin) } if (warn.change) warning("isWholeMonth() was previously not vectorized.\nThis has been corrected but might mess with previous code.\nCheck for calls:", pasteC(capture.output(sys.calls()), C="\n")) ## Same month months(start) == months(end) & ## same year year(start) == year(end) & ## one day before start is a different month months(start) != months(start - 1) & ## one day after end is a different month months(end) != months(end + 1) } WeekdaysStartingAt <- function(start=0, abbreviate=FALSE, factor=TRUE, dontWarnAboutSunday=FALSE) { ## The days of the week AllDays <- c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday") ## Allow for quick calls with abbreviate, such as WeekdaysStartAt(TRUE) if (is.logical(start)) { abbreviate <- start start <- 0 } ## Allows to accept dates, strings, etc for 'start', while avoiding errors if otherwise ## If can be converted, then convert, which will then be matched to an integer in the next step tried <- try(weekdays(as.Date(start)), silent=TRUE) if ( !is.na(tried) && !isErr(tried) ) start <- tried ## Convert to integer from day, or month/string from previous step. if (is.character(start)) start <- pmatch(tolower(start), tolower(AllDays)) - 1 ## Reminder to user if (start != 0 && !dontWarnAboutSunday) message("Rember, Sunday is Zero") if (isTRUE(abbreviate)) AllDays <- substr(AllDays, 1, 3) ## Expand start to six more, take mod 7. Then add one because R does not start at zero. ret <- AllDays[((start + 0:6) %% 7) + 1] ## Optionally create factor with current levels. (not setting levels will alphabetize) if (isTRUE(factor)) ret <- factor(ret, levels=ret) return(ret) } getWdays <- function() { getWeekdays(abbreviate=TRUE) } getWeekdays <- function(abbreviate=FALSE) { if (abbreviate) c("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat") else c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday") } daysInMonth <- function( d = Sys.Date() , m = as.numeric(format(d, "%m")) , y = if (missing(d)) 1 else as.numeric(format(d, "%Y")) , origin=.origin ) { ## based on function by @jamos125 & @Gregor ## from: http://stackoverflow.com/a/25021174/1492421 ## Allow for m to be character or month number if (!missing(m)) { if (is.character(m)) { m <- pmatch(tolower(m), tolower(month.name)) if (any(is.na(m))) warning ("Some values of 'm' did not match to a unique month name.\nNAs will be in results") } else if (is.numeric(m) && any(m < 1 || m > 12)) warning ("if 'm' is numeric it should be a value between 1 and 12.\nNAs will be in results") else if (is.Date(m)) { d <- m m <- as.numeric(format(d, "%m")) } } ## convert to Date if not already if (!missing(d) && !is.Date(d)) d <- as.Date(d, origin=origin) ## extract month and year (the latter for leap-year check) # Return the number of days in the month ret <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[m] ## Adjust for leap year febs <- m == 2 if (any(febs)) ret[febs] <- y[febs] %>% {((. %% 4 == 0 & . %% 100 != 0) | . %% 400 == 0)} %>% "+"(ret[febs]) return(ret) } monthsDiff <- function(x, y, origin=.origin, verbose=TRUE) { ## monthsDiff is x - y if (verbose) { x.nm <- capture.output(substitute(x)) y.nm <- capture.output(substitute(y)) message("Calculating monthsDiff as: ", x.nm, " - ", y.nm) } if (!inherits(x, "Date")) x <- as.Date(x, origin=origin) if (!inherits(y, "Date")) y <- as.Date(y, origin=origin) toNumb <- function(D) as.numeric(format(D, "%Y"))*12 + as.numeric(format(D, "%m")) toNumb(x) - toNumb(y) }