/R/functions.R

https://github.com/kjhealy/covdata · R · 216 lines · 69 code · 16 blank · 131 comment · 6 complexity · 68e16578f3246185c3d8d9abc6b8d072 MD5 · raw file

  1. #' @importFrom magrittr %>%
  2. #' @export
  3. magrittr::`%>%`
  4. #' Convenience 'not-in' operator
  5. #'
  6. #' Complement of the built-in operator `%in%`. Returns the elements of `x` that are not in `y`.
  7. #' @title `%nin%`
  8. #' @param x vector of items
  9. #' @param y vector of all values
  10. #' @return logical vector of items in x not in y
  11. #' @author Kieran Healy
  12. #' @rdname nin
  13. #' @examples
  14. #' fruit <- c("apples", "oranges", "banana")
  15. #' "apples" %nin% fruit
  16. #' "pears" %nin% fruit
  17. #' @export
  18. "%nin%" <- function(x, y) {
  19. return( !(x %in% y) )
  20. }
  21. #' @title FUNCTION_TITLE
  22. #' @description FUNCTION_DESCRIPTION
  23. #' @param date PARAM_DESCRIPTION
  24. #' @return OUTPUT_DESCRIPTION
  25. #' @details DETAILS
  26. #' @examples
  27. #' \dontrun{
  28. #' if(interactive()){
  29. #' #EXAMPLE1
  30. #' }
  31. #' }
  32. #' @rdname MMWRweekday
  33. #' @author Kieran Healy
  34. #' @source http://
  35. MMWRweekday <- function (date)
  36. {
  37. factor(strftime(as.Date(date), "%w"), levels = 0:6, labels = c("Sunday",
  38. "Monday", "Tuesday", "Wednesday", "Thursday", "Friday",
  39. "Saturday"))
  40. }
  41. #' @title FUNCTION_TITLE
  42. #' @description FUNCTION_DESCRIPTION
  43. #' @param year PARAM_DESCRIPTION
  44. #' @return OUTPUT_DESCRIPTION
  45. #' @details DETAILS
  46. #' @examples
  47. #' \dontrun{
  48. #' if(interactive()){
  49. #' #EXAMPLE1
  50. #' }
  51. #' }
  52. #' @rdname start_date
  53. #' @author AUTHOR_NAME
  54. #' @source http://
  55. start_date <- function (year)
  56. {
  57. jan1 = as.Date(paste(year, "-01-01", sep = ""))
  58. wday = as.numeric(MMWRweekday(jan1))
  59. jan1 - (wday - 1) + 7 * (wday > 4)
  60. }
  61. #' @title FUNCTION_TITLE
  62. #' @description FUNCTION_DESCRIPTION
  63. #' @param MMWRyear PARAM_DESCRIPTION
  64. #' @param MMWRweek PARAM_DESCRIPTION
  65. #' @param MMWRday PARAM_DESCRIPTION, Default: NULL
  66. #' @return OUTPUT_DESCRIPTION
  67. #' @details DETAILS
  68. #' @examples
  69. #' \dontrun{
  70. #' if(interactive()){
  71. #' #EXAMPLE1
  72. #' }
  73. #' }
  74. #' @rdname MMWRweek2Date
  75. #' @author Kieran Healy
  76. #' @source http://
  77. MMWRweek2Date <- function (MMWRyear, MMWRweek, MMWRday = NULL)
  78. {
  79. stopifnot(all(is.numeric(MMWRyear)))
  80. stopifnot(all(is.numeric(MMWRweek)))
  81. stopifnot(all(0 < MMWRweek & MMWRweek < 54))
  82. stopifnot(length(MMWRyear) == length(MMWRweek))
  83. if (is.null(MMWRday))
  84. MMWRday = rep(1, length(MMWRweek))
  85. stopifnot(all(0 < MMWRday & MMWRday < 8))
  86. jan1 = start_date(MMWRyear)
  87. return(jan1 + (MMWRweek - 1) * 7 + MMWRday - 1)
  88. }
  89. #' @title FUNCTION_TITLE
  90. #' @description FUNCTION_DESCRIPTION
  91. #' @param year PARAM_DESCRIPTION
  92. #' @param week PARAM_DESCRIPTION
  93. #' @param day PARAM_DESCRIPTION, Default: NULL
  94. #' @return OUTPUT_DESCRIPTION
  95. #' @details DETAILS
  96. #' @examples
  97. #' \dontrun{
  98. #' if(interactive()){
  99. #' #EXAMPLE1
  100. #' }
  101. #' }
  102. #' @seealso
  103. #' \code{\link[MMWRweek]{MMWRweek2Date}}
  104. #' @rdname mmwr_week_to_date
  105. #' @author Kieran Healy
  106. #' @source http://
  107. #' @export
  108. mmwr_week_to_date <- function (year, week, day = NULL)
  109. {
  110. year <- as.numeric(year)
  111. week <- as.numeric(week)
  112. day <- if (!is.null(day))
  113. as.numeric(day)
  114. else rep(1, length(week))
  115. week <- ifelse(0 < week & week < 54, week, NA)
  116. as.Date(ifelse(is.na(week), NA, MMWRweek2Date(year,
  117. week, day)), origin = "1970-01-01")
  118. }
  119. #' @title fmt_nc
  120. #' @description Format fmt_nc in df
  121. #' @param x df
  122. #' @return formatted string
  123. #' @details use in fn documentation
  124. #' @examples
  125. #' \dontrun{
  126. #' if(interactive()){
  127. #' #EXAMPLE1
  128. #' }
  129. #' }
  130. #' @rdname fmt_nc
  131. #' @author Kieran Healy
  132. fmt_nc <- function(x){
  133. prettyNum(ncol(x), big.mark=",", scientific=FALSE)
  134. }
  135. #' @title fmt_nr
  136. #' @description Format fmt_nr in df
  137. #' @param x df
  138. #' @return formatted string
  139. #' @details use in fn documentation
  140. #' @examples
  141. #' \dontrun{
  142. #' if(interactive()){
  143. #' #EXAMPLE1
  144. #' }
  145. #' }
  146. #' @author Kieran Healy
  147. fmt_nr <- function(x){
  148. prettyNum(nrow(x), big.mark=",", scientific=FALSE)
  149. }
  150. #' @title tabular
  151. #' @description Make an Rd table from a data frame
  152. #' @param df Data frame
  153. #' @param ... Other args
  154. #' @return Rd table
  155. #' @details DETAILS
  156. #' @examples
  157. #' \dontrun{
  158. #' if(interactive()){
  159. #' #EXAMPLE1
  160. #' }
  161. #' }
  162. #' @author Kieran Healy
  163. #' @source http://
  164. tabular <- function(df, ...) {
  165. stopifnot(is.data.frame(df))
  166. align <- function(x) if (is.numeric(x)) "r" else "l"
  167. col_align <- vapply(df, align, character(1))
  168. cols <- lapply(df, format, ...)
  169. contents <- do.call("paste",
  170. c(cols, list(sep = " \\tab ", collapse = "\\cr\n#' ")))
  171. paste("#' \\tabular{", paste(col_align, collapse = ""), "}{\n#' ",
  172. paste0("\\strong{", names(df), "}", sep = "", collapse = " \\tab "), " \\cr\n#' ",
  173. contents, "\n#' }\n", sep = "")
  174. }
  175. #' Make a table of stmf country years
  176. #'
  177. #' @param df The stmf data frame
  178. #' @return A tibble
  179. #' @details Get a table of country x year coverage for stmf
  180. #' @examples
  181. #' \dontrun{
  182. #' if(interactive()){
  183. #' #EXAMPLE1
  184. #' }
  185. #' }
  186. #' @author Kieran Healy
  187. #' @source http://
  188. stmf_country_years <- function(df = stmf) {
  189. df %>%
  190. dplyr::select(cname, year) %>%
  191. dplyr::group_by(cname, year) %>%
  192. dplyr::tally() %>%
  193. dplyr::mutate(n = as.character(n),
  194. n = dplyr::recode(n, "0" = "-", .default = "Y")) %>%
  195. dplyr::group_by(year, cname) %>%
  196. dplyr::arrange(year) %>%
  197. tidyr::pivot_wider(names_from = year, values_from = n) %>%
  198. dplyr::mutate(dplyr::across(where(is.character), dplyr::recode, .missing = "-")) %>%
  199. dplyr::arrange(cname)
  200. }